home *** CD-ROM | disk | FTP | other *** search
/ Total Network Tools 2002 / NextStepPublishing-TotalNetworkTools2002-Win95.iso / Archive / Web Server / TinyWeb Server.EXE / SRC.ZIP / xbase.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2000-12-05  |  74.0 KB  |  3,038 lines
  1. //////////////////////////////////////////////////////////////////////////
  2. //
  3. //  TinyWeb Copyright (C) 2000 RITLABS S.R.L.
  4. //
  5. //  This programs is free for commercial and non-commercial use as long as
  6. //  the following conditions are aheared to.
  7. //
  8. //  Copyright remains RITLABS S.R.L., and as such any Copyright notices
  9. //  in the code are not to be removed. If this package is used in a
  10. //  product, RITLABS S.R.L. should be given attribution as the owner
  11. //  of the parts of the library used. This can be in the form of a textual
  12. //  message at program startup or in documentation (online or textual)
  13. //  provided with the package.
  14. //
  15. //  Redistribution and use in source and binary forms, with or without
  16. //  modification, are permitted provided that the following conditions are
  17. //  met:
  18. //
  19. //  1. Redistributions of source code must retain the copyright
  20. //     notice, this list of conditions and the following disclaimer.
  21. //  2. Redistributions in binary form must reproduce the above copyright
  22. //     notice, this list of conditions and the following disclaimer in the
  23. //     documentation and/or other materials provided with the distribution.
  24. //  3. All advertising materials mentioning features or use of this software
  25. //     must display the following acknowledgement:
  26. //     "Based on TinyWeb Server by RITLABS S.R.L.."
  27. //
  28. //  THIS SOFTWARE IS PROVIDED BY RITLABS S.R.L. "AS IS" AND ANY EXPRESS
  29. //  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30. //  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31. //  DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
  32. //  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  33. //  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  34. //  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  35. //  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
  36. //  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  37. //  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  38. //  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39. //
  40. //  The licence and distribution terms for any publically available
  41. //  version or derivative of this code cannot be changed. i.e. this code
  42. //  cannot simply be copied and put under another distribution licence
  43. //  (including the GNU Public Licence).
  44. //
  45. //////////////////////////////////////////////////////////////////////////
  46.  
  47.  
  48.  
  49. unit xBase;
  50.  
  51. interface uses Windows, WinSock;
  52.  
  53. const
  54.  
  55.  
  56.   _INADDR_ANY = INADDR_ANY;
  57.   INVALID_FILE_ATTRIBUTES = INVALID_FILE_SIZE;
  58.   INVALID_FILE_TIME       = INVALID_FILE_SIZE;
  59.   INVALID_REGISTRY_KEY    = INVALID_HANDLE_VALUE;
  60.   INVALID_VALUE           = INVALID_HANDLE_VALUE;
  61.  
  62.   rrLoHexChar: array[0..$F] of char='0123456789abcdef';
  63.   rrHiHexChar: array[0..$F] of char='0123456789ABCDEF';
  64.  
  65.   SleepQuant = 1*60*1000; // 1 minute
  66.  
  67. { Maximum TColl size }
  68.  
  69.   MaxCollSize = $20000 div SizeOf(Pointer);
  70.  
  71. const
  72.       MMaxChars = 250;
  73.  
  74.  
  75. type
  76.     Str255 = String[255];
  77.     TByteTable = Array[Char] of Byte;
  78.     TBase64Table = (bsBase64, bsUUE, bsXXE);
  79.     TUUStr = String[MMaxChars];
  80.  
  81.  
  82.     TMimeCoder = class
  83.       Table: string;
  84.       MaxChars: Byte;
  85.       Pad: Char;
  86.       XChars: TByteTable;
  87.       constructor Create(AType: TBase64Table);
  88.       procedure   InitTable;
  89.       function    Encode(const Buf; N: byte) : string;
  90.       function    EncodeBuf(const Buf; N: byte; var OutBuf) : Integer;
  91.       function    EncodeStr(const S: String): String;
  92.       function    Decode(const S : String; var Buf): Integer;
  93.       function    DecodeBuf(const SrcBuf; SrcLen: Integer; var Buf): Integer;
  94.     end;
  95.  
  96.  
  97.     TSocketOption = (soBroadcast, soDebug, soDontLinger,
  98.                      soDontRoute, soKeepAlive, soOOBInLine,
  99.                      soReuseAddr, soNoDelay, soBlocking, soAcceptConn);
  100.  
  101.     TSocketOptions = Set of TSocketOption;
  102.  
  103.     TSocketClass = class of TSocket;
  104.  
  105.     TSocket = class
  106.     public
  107.       Dead: Integer;
  108.       FPort: DWORD;
  109.       FAddr: DWORD;
  110.       Handle: DWORD;
  111.       Status: Integer;
  112.       Registered: Boolean;
  113.       procedure RegisterSelf;
  114.       procedure DeregisterSelf;
  115.  
  116.       function Startup: Boolean; virtual;
  117.       function Handshake: Boolean; virtual;
  118.       destructor Destroy; override;
  119.  
  120.       function Read(var B; Size: DWORD): DWORD;
  121.       function Write(const B; Size: DWORD): DWORD;
  122.       function WriteStr(const s: string): DWORD;
  123.  
  124.       function _Write(const B; Size: DWORD): DWORD; virtual;
  125.       function _Read(var B; Size: DWORD): DWORD; virtual;
  126.  
  127.     end;
  128.  
  129.   TObjProc = procedure of object;
  130.   TForEachProc = procedure(P: Pointer) of object;
  131.  
  132.   PFileInfo = ^TFileInfo;
  133.   TFileInfo = record
  134.     Attr: DWORD;
  135.     Size: DWORD;
  136.     Time: DWORD;
  137.   end;
  138.  
  139.   TuFindData = record
  140.     Info: TFileInfo;
  141.     FName: string;
  142.   end;
  143.  
  144.   TCreateFileMode = (
  145.  
  146.    cRead,            // Specifies read access to the file
  147.    cWrite,           // Specifies write access to the file
  148.  
  149.    cFlag,
  150.  
  151.    cEnsureNew,       // Creates a NEW file. The function fails
  152.                      // if the specified file already exists.
  153.  
  154.    cTruncate,        // Once opened, the file is truncated so that
  155.                      // its size is zero bytes.
  156.  
  157.    cExisting,        //  For communications resources, console diveces
  158.  
  159.    cShareAllowWrite,
  160.    cShareDenyRead,
  161.  
  162.    cOverlapped,      // This flag enables more than one operation to be
  163.                      // performed simultaneously with the handle
  164.                      // (e.g. a simultaneous read and write operation).
  165.  
  166.    cRandomAccess,    // Indicates that the file is accessed randomly.
  167.                      // Windows uses this flag to optimize file caching.
  168.  
  169.    cSequentialScan,  // Indicates that the file is to be accessed
  170.                      // sequentially from beginning to end.
  171.  
  172.    cDeleteOnClose    // Indicates that the operating system is to delete
  173.                      // the file immediately after all of its handles
  174.                      // have been closed.
  175.  
  176.                     );
  177.  
  178.    TCreateFileModeSet = set of TCreateFileMode;
  179.  
  180. { Character set type }
  181.  
  182.   PCharSet = ^TCharSet;
  183.   TCharSet = set of Char;
  184.  
  185. { General arrays }
  186.  
  187.  
  188.   PCharArray = ^TCharArray;
  189.   TCharArray = array[0..MaxLongInt-1] of Char;
  190.  
  191.   PByteArray = ^TByteArray;
  192.   TByteArray = array[0..MaxLongInt-1] of Byte;
  193.  
  194.   PIntArray = ^TIntArray;
  195.   TIntArray = array[0..(MaxLongInt div 4)-1] of Integer;
  196.  
  197.   PDwordArray = ^TDwordArray;
  198.   TDwordArray = array[0..(MaxLongInt div 4)-1] of DWORD;
  199.  
  200.  
  201.   PvIntArr = ^TvIntArr;
  202.   TvIntArr = record
  203.     Arr: PIntArray;
  204.     Cnt: Integer;
  205.   end;
  206.  
  207.   PBoolean   = ^Boolean;
  208.  
  209.  
  210.   PItemList = ^TItemList;
  211.   TItemList = array[0..MaxCollSize - 1] of Pointer;
  212.  
  213.   TThreadMethod = procedure of object;
  214.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  215.     tpTimeCritical);
  216.  
  217.   TThread = class
  218.   private
  219.     FHandle: THandle;
  220.     FThreadID: THandle;
  221.     FTerminated: Boolean;
  222.     FSuspended: Boolean;
  223.     FFreeOnTerminate: Boolean;
  224.     FFinished: Boolean;
  225.     FReturnValue: DWORD;
  226.     function GetPriority: TThreadPriority;
  227.     procedure SetPriority(Value: TThreadPriority);
  228.     procedure SetSuspended(Value: Boolean);
  229.   protected
  230.     procedure Execute; virtual; abstract;
  231.     property ReturnValue: DWORD read FReturnValue write FReturnValue;
  232.     property Terminated: Boolean read FTerminated;
  233.   public
  234.     constructor Create(CreateSuspended: Boolean);
  235.     destructor Destroy; override;
  236.     procedure Resume;
  237.     procedure Suspend;
  238.     procedure Terminate;
  239.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  240.     property Handle: THandle read FHandle;
  241.     property Priority: TThreadPriority read GetPriority write SetPriority;
  242.     property Suspended: Boolean read FSuspended write SetSuspended;
  243.     property ThreadID: THandle read FThreadID;
  244.   end;
  245.  
  246.   TAdvObject = class;
  247.  
  248.   TAdvObject = class
  249.   end;
  250.  
  251.   TAdvCpObject = class(TAdvObject)
  252.     function Copy: Pointer; virtual; abstract;
  253.   end;
  254.  
  255.   TAdvClass = class of TAdvObject;
  256.  
  257.   TCollClass = class of TColl;
  258.  
  259.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  260.  
  261.   TColl = class(TAdvCpObject)
  262.   protected
  263.     FCount: Integer;
  264.     FCapacity: Integer;
  265.     FDelta: Integer;
  266.     CS: TRTLCriticalSection;
  267.     Shared: Integer;
  268.   public
  269.     FList: PItemList;
  270.     procedure CopyItemsTo(Coll: TColl);
  271.     function Copy: Pointer; override;
  272.     function CopyItem(AItem: Pointer): Pointer; virtual;
  273.     procedure DoInit(ALimit, ADelta: Integer);
  274.     constructor Create;
  275.     destructor Destroy; override;
  276.     function At(Index: Integer): Pointer;
  277.     procedure AtDelete(Index: Integer);
  278.     procedure AtFree(Index: Integer);
  279.     procedure AtInsert(Index: Integer; Item: Pointer);
  280.     procedure AtPut(Index: Integer; Item: Pointer);
  281.     procedure Delete(Item: Pointer);
  282.     procedure DeleteAll;
  283.     procedure FFree(Item: Pointer);
  284.     procedure FreeAll;
  285.     procedure FreeItem(Item: Pointer); virtual;
  286.     function IndexOf(Item: Pointer): Integer; virtual;
  287.     procedure Insert(Item: Pointer); virtual;
  288.     procedure Add(Item: Pointer);
  289.     procedure Pack;
  290.     procedure SetCapacity(NewCapacity: Integer);
  291.     procedure MoveTo(CurIndex, NewIndex: Integer);
  292.     property Items[Idx: Integer]: Pointer read At write AtPut; default;
  293.     property Count: Integer read FCount;
  294.     property First: Pointer index 0 read At write AtPut;
  295.     procedure ForEach(Proc: TForEachProc); virtual;
  296.     procedure Sort(Compare: TListSortCompare);
  297.     procedure Concat(AColl: TColl);
  298.     procedure Enter;
  299.     procedure Leave;
  300.   end;
  301.  
  302.   TSortedColl = class(TColl)
  303.   public
  304.     Duplicates: Boolean;
  305.     function Compare(Key1, Key2: Pointer): Integer; virtual; abstract;
  306.     function KeyOf(Item: Pointer): Pointer; virtual;
  307.     function IndexOf(Item: Pointer): Integer; override;
  308.     procedure Insert(Item: Pointer); override;
  309.     function Search(Key: Pointer; var Index: Integer): Boolean; virtual;
  310.   end;
  311.  
  312. { TStringColl object }
  313.  
  314.   TStringColl = class(TSortedColl)
  315.   protected
  316.     procedure SetString(Index: Integer; const Value: string);
  317.     function GetString(Index: Integer): string;
  318.   public
  319.     function KeyOf(Item: Pointer): Pointer; override;
  320.     procedure FreeItem(Item: Pointer); override;
  321.     function Compare(Key1, Key2: Pointer): Integer; override;
  322.     function CopyItem(AItem: Pointer): Pointer; override;
  323.     function Copy: Pointer; override;
  324.     procedure Ins(const S: string);
  325.     procedure Ins0(const S: string);
  326.     procedure Add(const S: string);
  327.     procedure AtIns(Index: Integer; const Item: string);
  328.     property Strings[Index: Integer]: string read GetString write SetString; default;
  329.     function  IdxOf(Item: string): Integer;
  330.     procedure AppendTo(AColl: TStringColl);
  331.     procedure Concat(AColl: TStringColl);
  332.     procedure AddStrings(Strings: TStringColl; Sort: Boolean);
  333.     procedure Fill(const AStrs: array of string);
  334.     function Found(const Str: string): Boolean;
  335.     function FoundU(const Str: string): Boolean;
  336.     function FoundUC(const Str: string): Boolean;
  337.     procedure FillEnum(Str: string; Delim: Char; Sorted: Boolean);
  338.     function LongString: string;
  339.     function LongStringD(c: char): string;
  340.     procedure SetTextStr(const Value: string);
  341.   end;
  342.  
  343.  
  344. { --- string routines }
  345.  
  346. function  AddRightSpaces(const S: string; NumSpaces: Integer): string;
  347. procedure AddStr(var S: string ; C : char);
  348. procedure Add_Str(var S: ShortString ; C : char);
  349. function  CompareStr(const S1, S2: string): Integer; assembler;
  350. function  CopyLeft(const S: string; I: Integer): string;
  351. procedure DelDoubles(const St : string;var Source : string);
  352. procedure DelFC(var s: string);
  353. procedure DelLC(var s: string);
  354. function  DelLeft(const S: string): string;
  355. function  DelRight(const S: string): string;
  356. function  DelSpaces(const s: string): string;
  357. procedure DeleteLeft(var S: string; I: Integer);
  358. function  DigitsOnly(const AStr: string): Boolean;
  359. procedure DisposeStr(P: PString);
  360. function  ExpandFileName(const FileName: string): string;
  361. function  ExtractFilePath(const FileName: string): string;
  362. function  ExtractDir(const S: string): string;
  363. function  ExtractFileRoot(const FileName: string): string;
  364. function  ExtractFileExt(const FileName: string): string;
  365. function  ExtractFileName(const FileName: string): string;
  366. function  ExtractFileDrive(const FileName: string): string;
  367. function  ExtractFileDir(const FileName: string): string;
  368. procedure FSplit(const FName: string; var Path, Name, Ext: string);
  369. procedure FillCharSet(const AStr: string; var CharSet: TCharSet);
  370. function GetWrdStrictUC(var s,w:string): Boolean;
  371. function GetWrdStrict(var s,w:string): Boolean;
  372. function GetWrdD(var s,w:string): Boolean;
  373. function GetWrdA(var s,w:string): Boolean;
  374. function GetWrd(var s,w:string;c:char): Boolean;
  375. function  Hex2(a: Byte): string;
  376. function  Hex4(a: Word): string;
  377. function  Hex8(a: DWORD): string;
  378. function  Int2Hex(a: Integer): string;
  379. function  Int2Str(L: Integer): string;
  380. function  ItoS(I: Integer): string;
  381. function  ItoSz(I, Width: Integer): string;
  382. function  LastDelimiter(const Delimiters, S: string): Integer;
  383. function  LowerCase(const S: string): string;
  384. function  MakeFullDir(const D, S: string): string;
  385. function  MakeNormName(const Path, Name: string): string;
  386. function  MonthE(m: Integer): string;
  387. function  NewStr(const S: string): PString;
  388. function  Replace(const Pattern, ReplaceString: string; var S: string): Boolean;
  389. function  StoI(const S: string): Integer;
  390. function  StrEnds(const S1, S2: string): Boolean;
  391. function  StrRight(const S: string; Num: Integer): string;
  392. function  UpperCase(const S: string): string;
  393. function  WipeChars(const AStr, AWipeChars: string): string;
  394. function  _Val(const S: string; var V: Integer): Boolean;
  395.  
  396. { --- RFC Routines }
  397.  
  398. function  ProcessQuotes(var s: string): Boolean;
  399. function  UnpackPchars(var s: string): Boolean;
  400. function  UnpackUchars(var s: string): Boolean;
  401. function  __alpha(c: char): Boolean;
  402. function  __ctl(c: char): Boolean;
  403. function  __digit(c: char): Boolean;
  404. function  __extra(c: char): Boolean;
  405. function  __national(c: char): Boolean;
  406. function  __pchar(c: char): Boolean;
  407. function  __reserved(c: char): Boolean;
  408. function  __safe(c: char): Boolean;
  409. function  __uchar(c: char): Boolean;
  410. function  __unsafe(c: char): Boolean;
  411.  
  412. { --- Basic Routines }
  413.  
  414. function  Buf2Str(const Buffer): string;
  415. procedure Clear(var Buf; Count: Integer);
  416. function  CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  417. procedure FreeObject(var O);
  418. procedure LowerPrec(var A, B: Integer; Bits: Byte);
  419. function  MemEqu(const A, B; Sz: Integer): Boolean;
  420. function  MaxI(A, B: Integer): Integer;
  421. function  MinI(A, B: Integer): Integer;
  422. function  MaxD(A, B: DWORD): DWORD;
  423. function  MinD(A, B: DWORD): DWORD;
  424. function  NulSearch(const Buffer): Integer;
  425. function  NumBits(I: Integer): Integer;
  426. procedure XAdd(var Critical, Normal); assembler;
  427. procedure XChg(var Critical, Normal); assembler;
  428.  
  429. { --- Win32 Events Extentions }
  430.  
  431. function  CreateEvtA: DWORD;
  432. function  CreateEvt(Initial: Boolean): DWORD;
  433. function  SignaledEvt(id: DWORD): Boolean;
  434. function  WaitEvt(const id: TWOHandleArray; Timeout: DWORD): DWORD;
  435. function  WaitEvtA(nCount: Integer; lpHandles: PWOHandleArray; Timeout: DWORD): DWORD;
  436.  
  437. { --- Win32 API Hooks }
  438.  
  439. function  ClearHandle(var Handle: THandle): Boolean;
  440. procedure CloseHandles(const Handles: array of DWORD);
  441. function  FileExists(const FName: string): Boolean;
  442. function  FindExecutable(FileName, Directory: PChar; Result: PChar): HINST; stdcall;
  443. function  GetEnvVariable(const Name: string): string;
  444. function  GetFileNfo(const FName: string; var Info: TFileInfo; NeedAttr: Boolean): Boolean;
  445. function  GetFileNfoByHandle(Handle: DWORD; var Info: TFileInfo): Boolean;
  446. function  ZeroHandle(var Handle: THandle): Boolean;
  447.  
  448. function  _CreateFile(const FName: string; Mode: TCreateFileModeSet): DWORD;
  449. function  _CreateFileSecurity(const FName: string; Mode: TCreateFileModeSet; lpSecurityAttributes: PSecurityAttributes): DWORD;
  450. function  _GetFileSize(const FName: string): DWORD;
  451.  
  452. function _MatchMaskBody(AName, AMask: string; SupportPercent: Boolean): Boolean;
  453. function _MatchMask(const AName: string; AMask: string; SupportPercent: Boolean): Boolean;
  454. function MatchMask(const AName, AMask: string): Boolean;
  455.  
  456. function  SysErrorMsg(ErrorCode: DWORD): string;
  457.  
  458. { --- Registry Routines }
  459.  
  460. function  CreateRegKey(const AFName: string): HKey;
  461. function  OpenRegKeyEx(const AName: string; AMode: DWORD): HKey;
  462. function  OpenRegKey(const AName: string): DWORD;
  463. function  ReadRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  464. function  ReadRegInt(Key: DWORD; const AStrName: string): DWORD;
  465. function  ReadRegString(Key: DWORD; const AStrName: string): string;
  466. function  WriteRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  467. function  WriteRegInt(Key: DWORD; const AStrName: string; AValue: DWORD): Boolean;
  468. function  WriteRegString(Key: DWORD; const AStrName, AStr: string): Boolean;
  469.  
  470. { --- Winsock tools }
  471.  
  472. function  AddrInet(i: DWORD): string;
  473. function  GetHostNameByAddr(Addr: DWORD): string;
  474. function  Inet2addr(const s: string): DWORD;
  475. function  InetAddr(const s: string): DWORD;
  476.  
  477. { --- Misc tools }
  478.  
  479. procedure GlobalFail;
  480. function  _LogOK(const Name: string; var Handle: DWORD): Boolean;
  481. procedure xBaseDone;
  482. procedure xBaseInit;
  483. procedure uCvtSetFileTime(T: DWORD; var L, H: DWORD);
  484. function uCvtGetFileTime(L, H: DWORD): DWORD;
  485. function uGetSystemTime: DWORD;
  486. function Vl(const s: string): DWORD;
  487. function StrAsg(const Src: string): string;
  488.  
  489. type
  490.   TResetterThread = class(TThread)
  491.     TimeToSleep,
  492.     oSleep: DWORD;
  493.     constructor Create;
  494.     procedure Execute; override;
  495.     destructor Destroy; override;
  496.   end;
  497.  
  498.  
  499. var
  500.   ResetterThread: TResetterThread;
  501.   TimeZoneBias: Integer;
  502.   SocketsColl: TColl;
  503.   SocksCount: Integer;
  504.  
  505. const
  506.   CServerVersion = '1.9';
  507.   CServerProductName = 'TinyWeb';
  508.   CServerName = CServerProductName+'/'+CServerVersion;
  509.   CMB_FAILED = MB_APPLMODAL or MB_OK or MB_ICONSTOP;
  510.  
  511.  
  512. implementation
  513.  
  514.  
  515. ////////////////////////////////////////////////////////////////////////
  516. //                                                                    //
  517. //                          Time Routines                             //
  518. //                                                                    //
  519. ////////////////////////////////////////////////////////////////////////
  520.  
  521.  
  522.  
  523. const
  524.   cTimeHi   = 27111902;
  525.   cTimeLo   = -717324288;
  526.   cSecScale = 10000000;
  527.   cAgeScale = 10000;
  528.  
  529. function uCvtGetFileTime(L, H: DWORD): DWORD; assembler;
  530. asm
  531.   mov ecx, cSecScale
  532.   sub eax, cTimeLo
  533.   sbb edx, cTimeHi
  534.   jns @@ns
  535.   mov eax, 0
  536.   jmp @@ok
  537. @@ns:
  538.   div ecx
  539.   test eax, eax
  540.   jns @@ok
  541.   mov eax, MaxInt
  542. @@ok:
  543. end;
  544.  
  545. function uCvtGetFileAge(L, H: DWORD): DWORD; assembler;
  546. asm
  547.   mov ecx, cAgeScale
  548.   div ecx
  549. end;
  550.  
  551.  
  552. procedure uCvtSetFileTime(T: DWORD; var L, H: DWORD); assembler;
  553. asm
  554.   push edx
  555.   push ebx
  556.   mov  ebx, cSecScale
  557.   mul  ebx
  558.   pop  ebx
  559.   add  eax, cTimeLo
  560.   adc  edx, cTimeHi
  561.   mov  [ecx], edx
  562.   pop  edx
  563.   mov  [edx], eax
  564. end;
  565.  
  566.  
  567. procedure uNix2WinTime(I: DWORD; var T: TSystemTime);
  568. var
  569.   F: TFileTime;
  570. begin
  571.   uCvtSetFileTime(I, F.dwLowDateTime, F.dwHighDateTime);
  572.   FileTimeToSystemTime(F, T);
  573. end;
  574.  
  575. function uWin2NixTime(const T: TSystemTime): DWORD;
  576. var
  577.   F: TFileTime;
  578. begin
  579.   SystemTimeToFileTime(T, F);
  580.   Result := uCvtGetFileTime(F.dwLowDateTime, F.dwHighDateTime);
  581. end;
  582.  
  583.  
  584.  
  585. function uGetLocalTime: DWORD;
  586. begin
  587.   Result := uGetLocalTime;
  588. end;
  589.  
  590. function uGetSystemTime: DWORD;
  591. var
  592.   T: TFileTime;
  593. begin
  594.   GetSystemTimeAsFileTime(T);
  595.   Result := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  596. end;
  597.  
  598. function uSetFileTimeByHandle(Handle: DWORD; uTime: DWORD): Boolean;
  599. var
  600.   F: TFileTime;
  601. begin
  602.   uCvtSetFileTime(uTime, F.dwLowDateTime, F.dwHighDateTime);
  603.   Result := SetFileTime(Handle, nil, nil, @F);
  604. end;
  605.  
  606. function uSetFileTime(const FName: string; uTime: DWORD): Boolean;
  607. var
  608.   Handle: DWORD;
  609. begin
  610.   Result := False;
  611.   Handle := _CreateFile(FName, [cWrite, cExisting]);
  612.   if Handle = INVALID_HANDLE_VALUE then Exit;
  613.   Result := uSetFileTimeByHandle(Handle, uTime);
  614.   CloseHandle(Handle);
  615. end;
  616.  
  617. procedure CvtFD(const wf: TWin32FindData; var FindData: TuFindData);
  618. begin
  619.   FindData.Info.Attr := wf.dwFileAttributes;
  620.   FindData.Info.Time := uCvtGetFileTime(wf.ftLastWriteTime.dwLowDateTime, wf.ftLastWriteTime.dwHighDateTime);
  621.   FindData.Info.Size := wf.nFileSizeLow;
  622.   FindData.FName := Buf2Str(wf.cFileName);
  623. end;
  624.  
  625. function uFindFirst(const FName: string; var FindData: TuFindData): DWORD;
  626. var
  627.   wf: TWin32FindData;
  628. begin
  629.   Result := FindFirstFile(PChar(FName), wf);
  630.   if Result <> INVALID_HANDLE_VALUE then CvtFD(wf, FindData);
  631. end;
  632.  
  633. function uFindNext(Handle: DWORD; var FindData: TuFindData): Boolean;
  634. var
  635.   wf: TWin32FindData;
  636. begin
  637.   Result := FindNextFile(Handle, wf);
  638.   if Result then CvtFD(wf, FindData);
  639. end;
  640.  
  641. function uFindClose(Handle: DWORD): Boolean;
  642. begin
  643.   Result := Windows.FindClose(Handle);
  644. end;
  645.  
  646.  
  647.  
  648. ////////////////////////////////////////////////////////////////////////
  649. //                                                                    //
  650. //                         string Routines                            //
  651. //                                                                    //
  652. ////////////////////////////////////////////////////////////////////////
  653.  
  654.  
  655. function IsWild(const S: string): Boolean;
  656. begin
  657.   Result := (Pos('*',S)>0) or (Pos('?', S)>0);
  658. end;
  659.  
  660. function TrimZeros(S: string): string;
  661. var
  662.   I, J : Integer;
  663. begin
  664.   I := Length(S);
  665.   while (I > 0) and (S[I] <= ' ') do
  666.     Dec(I);
  667.   J := 1;
  668.   while (J < I) and ((S[J] <= ' ') or (S[J] = '0')) do
  669.     Inc(J);
  670.   TrimZeros := Copy(S, J, (I-J)+1);
  671. end;
  672.  
  673. function BothKVC(const S: string): Boolean;
  674. begin
  675.   Result := (Copy(S, 1, 1)='"') and (Copy(S, Length(S), 1)='"');
  676. end;
  677.  
  678. function AddRightSpaces;
  679. begin
  680.   SetLength(Result, NumSpaces);
  681.   FillChar(Result[1], NumSpaces, ' ');
  682.   Move(S[1], Result[1], MinI(NumSpaces, Length(S)));
  683. end;
  684.  
  685. function Hex2;
  686. begin
  687.   SetLength(Result, 2);
  688.   Result[1] := rrLoHexChar[a shr 4];
  689.   Result[2] := rrLoHexChar[a and $F];
  690. end;
  691.  
  692. function Hex4;
  693.   var I: Integer;
  694. begin
  695.   SetLength(Result, 4);
  696.   for I := 0 to 3 do
  697.     begin Result[4-I] := rrLoHexChar[A and $F]; A := A shr 4; end;
  698. end;
  699.  
  700. function Hex8;
  701.   var I: DWORD;
  702. begin
  703.   SetLength(Result, 8);
  704.   for I := 0 to 7 do
  705.     begin Result[8-I] := rrLoHexChar[A and $F]; A := A shr 4; end;
  706. end;
  707.  
  708. function Int2Hex(a: Integer): string;
  709. begin
  710.   Result := Hex8(a);
  711.   while (Length(Result)>1) and (Result[1]='0') do DelFC(Result);
  712. end;
  713.  
  714. function MakeFullDir(const D, S: string): string;
  715. begin
  716.   if (Pos(':', S) > 0) or (Copy(S, 1, 2) = '\\') then Result := S else
  717.     if Copy(S, 1, 1) = '\' then Result := MakeNormName(Copy(D, 1, Pos(':',D)), Copy(S, 2, Length(S)-1)) else
  718.       Result := MakeNormName(D,S);
  719. end;
  720.  
  721. function ExtractDir;
  722. var
  723.   i: Integer;
  724. begin
  725.   Result := S; i := Length(S);
  726.   if (i > 3) and (S[i] = '\') then DelLC(Result);
  727. end;
  728.  
  729. function MakeNormName;
  730. begin
  731.   Result := Path;
  732.   if (Result <> '') and (Result[Length(Result)] <> '\') then AddStr(Result, '\');
  733.   Result := Result + Name;
  734. end;
  735.  
  736. procedure AddStr;
  737. begin
  738.   S := S + C;
  739. end;
  740.  
  741. procedure Add_Str(var S: ShortString ; C : char);
  742. var
  743.   sl: Byte absolute S;
  744. begin
  745.   Inc(sl); S[sl] := C;
  746. end;
  747.  
  748. procedure FSplit(const FName: string; var Path, Name, Ext: string);
  749. type
  750.   TStep = (sExt, sName, sPath);
  751. var
  752.   Step : TStep;
  753.   I: Integer;
  754.   C: Char;
  755. begin
  756.   I := Length(FName);
  757.   if Pos('.', FName) = 0 then Step := sName else Step := sExt;
  758.   Path := ''; Name := ''; Ext  := '';
  759.   while I > 0 do
  760.   begin
  761.     C := FName[I]; Dec(I);
  762.     case Step of
  763.       sExt  :
  764.         case C of
  765.           '.': begin Ext := C + Ext; Inc(Step); end;
  766.           '\', ':': begin Name := Ext; Ext := ''; Path := C; Step := sPath; end;
  767.           else Ext := C + Ext;
  768.         end;
  769.       sName : if (C = '\') or (C = ':') then begin Path := C; Inc(Step) end else Name := C + Name;
  770.       sPath : Path := C + Path;
  771.     end;
  772.   end;
  773. end;
  774.  
  775.  
  776. function Replace;
  777.  var I, J: Integer;
  778.      LP, LR: Integer;
  779. begin
  780.  Result := False;
  781.  J := 1;
  782.  LP := Length(Pattern);
  783.  LR := Length(ReplaceString);
  784.  repeat
  785.   I := Pos(Pattern, CopyLeft(S, J));
  786.   if I > 0 then
  787.    begin
  788.     Delete(S, J+I-1, LP);
  789.     Insert(ReplaceString, S, J+I-1);
  790.     Result := True;
  791.    end;
  792.   Inc(J, I + LR - 1);
  793.  until I = 0;
  794. end;
  795.  
  796. procedure DelDoubles;
  797. var
  798.   i: Integer;
  799. begin
  800.   repeat
  801.     i := Pos(ST,Source);
  802.     if i = 0 then Break;
  803.     Delete(Source,I,1);
  804.   until False;
  805. end;
  806.  
  807. function ItoS(I: Integer): string;
  808. begin
  809.   Str(I, Result);
  810. end;
  811.  
  812. function ItoSz(I, Width: Integer): string;
  813. begin
  814.   Result := ItoS(I);
  815.   while Length(Result)<Width do Result := '0'+Result;
  816. end;
  817.  
  818. function DelLeft(const S: string): string;
  819. var
  820.   I, L: Integer;
  821. begin
  822.   I := 1;
  823.   L := Length(S);
  824.   while I<=L do
  825.   begin
  826.     case S[I] of #9, ' ':; else Break end;
  827.     Inc(I);
  828.   end;
  829.   Result := Copy(S, I, L+1-I);
  830. end;
  831.  
  832. function DelRight(const S: string): string;
  833. var
  834.   I: Integer;
  835. begin
  836.   I := Length(S);
  837.   while I>0 do
  838.   begin
  839.     case S[I] of #9, ' ':; else Break end;
  840.     Dec(I);
  841.   end;
  842.   Result := Copy(S, 1, I);
  843. end;
  844.  
  845. function DelSpaces(const s: string): string;
  846. begin
  847.   Result := DelLeft(DelRight(s));
  848. end;
  849.  
  850. procedure DelFC(var s: string);
  851. begin
  852.   Delete(s, 1, 1);
  853. end;
  854.  
  855. procedure DelLC(var s: string);
  856. var
  857.   l: Integer;
  858. begin
  859.   l := Length(s);
  860.   case l of
  861.     0 : ;
  862.     1 : s := '';
  863.     else SetLength(s, l-1);
  864.   end;
  865. end;
  866.  
  867. function Int2Str(L: Integer): string;
  868. var I: Integer;
  869. begin
  870.   Result := ItoS(L);
  871.   I := Length(Result)-2;
  872.   while I > 1 do
  873.     begin
  874.       Insert(','{ThousandSeparator}, Result, I);
  875.       Dec(I, 3);
  876.     end;
  877. end;
  878.  
  879. function ExtractFileRoot(const FileName: string): string;
  880. begin
  881.   Result := Copy(FileName, 1, Pos(':',FileName)+1);
  882. end;
  883.  
  884. function WipeChars;
  885. var
  886.   i, j: Integer;
  887. begin
  888.   Result := ''; j := Length(AStr);
  889.   for i := 1 to j do if Pos(AStr[I], AWipeChars) = 0 then AddStr(Result, AStr[I]);
  890. end;
  891.  
  892. procedure FillCharSet(const AStr: string; var CharSet: TCharSet);
  893. var
  894.   i: Integer;
  895. begin
  896.   CharSet := [];
  897.   for i := 1 to Length(AStr) do Include(CharSet, AStr[i]);
  898. end;
  899.  
  900. function DigitsOnly(const AStr: string): Boolean;
  901. var
  902.   i: Integer;
  903. begin
  904.   Result := False;
  905.   if AStr = '' then Exit;
  906.   for i := 1 to Length(AStr) do if not __digit(AStr[i]) then Exit;
  907.   Result := True;
  908. end;
  909.  
  910. function GetWrdD(var s,w:string): Boolean;
  911. begin
  912.  Result := False;
  913.  w:=''; if s='' then Exit;
  914.  while (Length(s)>0) and ((s[1]<'0') or (s[1]>'9')) do begin DelFC(s) end;
  915.  while (Length(s)>0) and (s[1]>='0') and (s[1]<='9') do begin w:=w+s[1];DelFC(s) end;
  916.  DelFC(s);
  917.  Result := True;
  918. end;
  919.  
  920. function GetWrdA(var s,w:string): Boolean;
  921. begin
  922.  Result := False;
  923.  w:=''; if s='' then Exit;
  924.  while (Length(s)>0) and ((UpCase(s[1])<'A') or (UpCase(s[1])>'Z')) do begin DelFC(s) end;
  925.  while (Length(s)>0) and (UpCase(s[1])>='A') and (UpCase(s[1])<='Z') do begin w:=w+s[1];DelFC(s) end;
  926.  DelFC(s);
  927.  Result := True;
  928. end;
  929.  
  930.  
  931. function  GetWrd(var s,w:string;c:char): Boolean;
  932. var
  933.   i, j: Integer;
  934. begin
  935.  Result := False;
  936.  w := ''; if s = '' then Exit;
  937.  if (c = ' ') and (Pos(' ', s) > 0) then s := DelSpaces(s);
  938.  j := 0;
  939.  for i := 1 to Length(s) do
  940.  begin
  941.    if s[i] = c then Break;
  942.    Inc(j);
  943.  end;
  944.  w := Copy(s, 1, j);
  945.  Delete(s, 1, j);
  946.  Result := s = '';
  947.  if not Result then Delete(s, 1, 1);
  948. end;
  949.  
  950. function GetWrdStrict(var s,w:string): Boolean;
  951. var
  952.   i, j: Integer;
  953. begin
  954.  Result := False;
  955.  w := ''; if s = '' then Exit;
  956.  j := 0;
  957.  for i := 1 to Length(s) do
  958.  begin
  959.    if s[i] = ' ' then Break;
  960.    Inc(j);
  961.  end;
  962.  w := Copy(s, 1, j);
  963.  Delete(s, 1, j);
  964.  Result := s = '';
  965.  if not Result then Delete(s, 1, 1);
  966. end;
  967.  
  968. function GetWrdStrictUC(var s,w:string): Boolean;
  969. var
  970.   i, j: Integer;
  971. begin
  972.  Result := False;
  973.  w := ''; if s = '' then Exit;
  974.  j := 0;
  975.  for i := 1 to Length(s) do
  976.  begin
  977.    if s[i] = ' ' then Break;
  978.    Inc(j);
  979.  end;
  980.  w := UpperCase(Copy(s, 1, j));
  981.  Delete(s, 1, j);
  982.  Result := s = '';
  983.  if not Result then Delete(s, 1, 1);
  984. end;
  985.  
  986. function StrRight(const S: string; Num: Integer): string;
  987. begin
  988.   Result := Copy(S, Length(S)-Num+1, Num);
  989. end;
  990.  
  991. function StrEnds(const S1, S2: string): Boolean;
  992. begin
  993.   Result := StrRight(S1, Length(S2)) = S2;
  994. end;
  995.  
  996. function CopyLeft(const S: string; I: Integer): string;
  997. begin
  998.   Result := Copy(S, I, Length(S)-I+1);
  999. end;
  1000.  
  1001. procedure DeleteLeft(var S: string; I: Integer);
  1002. begin
  1003.   Delete(S, I, Length(S)-I+1);
  1004. end;
  1005.  
  1006.  
  1007. ////////////////////////////////////////////////////////////////////////
  1008. //                                                                    //
  1009. //                          Basic Routines                            //
  1010. //                                                                    //
  1011. ////////////////////////////////////////////////////////////////////////
  1012.  
  1013. procedure Clear(var Buf; Count: Integer);
  1014. begin
  1015.   FillChar(Buf, Count, 0);
  1016. end;
  1017.  
  1018. function MemEqu(const A, B; Sz: Integer): Boolean;
  1019. asm
  1020.     push  ebx
  1021.     xchg  eax, ebx
  1022.     jmp   @1
  1023.  
  1024. @0: inc   edx
  1025. @1: mov   al, [ebx]
  1026.     inc   ebx
  1027.     cmp   al, [edx]
  1028.     jne   @@Wrong
  1029.     dec   ecx
  1030.     jnz   @0
  1031.  
  1032.     mov   eax, 1
  1033.     jmp   @@End
  1034. @@Wrong:
  1035.     mov   eax, 0
  1036. @@End:
  1037.     pop   ebx
  1038. end;
  1039.  
  1040. function MaxI(A, B: Integer): Integer; assembler;
  1041. asm
  1042.   cmp  eax, edx
  1043.   jg   @@g
  1044.   xchg eax, edx
  1045. @@g:
  1046. end;
  1047.  
  1048.  
  1049. function MinI(A, B: Integer): Integer; assembler;
  1050. asm
  1051.   cmp  eax, edx
  1052.   jl   @@l
  1053.   xchg eax, edx
  1054. @@l:
  1055. end;
  1056.  
  1057.  
  1058. function MaxD(A, B: DWORD): DWORD; assembler;
  1059. asm
  1060.   cmp  eax, edx
  1061.   ja   @@a
  1062.   xchg eax, edx
  1063. @@a:
  1064. end;
  1065.  
  1066.  
  1067. function MinD(A, B: DWORD): DWORD; assembler;
  1068. asm
  1069.   cmp  eax, edx
  1070.   jb   @@b
  1071.   xchg eax, edx
  1072. @@b:
  1073. end;
  1074.  
  1075. procedure XChg(var Critical, Normal); assembler;
  1076. asm
  1077.   mov  ecx, [edx]
  1078.   xchg [eax], ecx
  1079.   mov  [edx], ecx
  1080. end;
  1081.  
  1082. function NulSearch; assembler;
  1083. asm;
  1084.   CLD
  1085.   PUSH    EDI
  1086.   MOV     EDI, Buffer
  1087.   XOR     AL,  AL
  1088.   MOV     ECX, -1
  1089.   REPNE   SCASB
  1090.   XCHG    EAX,ECX
  1091.   NOT     EAX
  1092.   DEC     EAX
  1093.   POP     EDI
  1094. end;
  1095.  
  1096. function Buf2Str(const Buffer): string;
  1097. var
  1098.   I: Integer;
  1099. begin
  1100.   I := NulSearch(Buffer);
  1101.   if I = 0 then Result := '' else
  1102.   begin
  1103.     SetLength(Result, I);
  1104.     Move(Buffer, Result[1], I);
  1105.   end;
  1106. end;
  1107.  
  1108. procedure LowerPrec(var A, B: Integer; Bits: Byte);
  1109. var
  1110.   C: ShortInt;
  1111. begin
  1112.   C := MaxI(NumBits(A), NumBits(B))-Bits;
  1113.   if C <= 0 then Exit;
  1114.   A := A shr C;
  1115.   B := B shr C;
  1116. end;
  1117.  
  1118.  
  1119.  
  1120. ////////////////////////////////////////////////////////////////////////
  1121. //                                                                    //
  1122. //                      Win32 Events Extentions                       //
  1123. //                                                                    //
  1124. ////////////////////////////////////////////////////////////////////////
  1125.  
  1126.  
  1127.  
  1128. function CreateEvtA;
  1129. begin
  1130.   Result := CreateEvent(nil, False, False, nil);
  1131. end;
  1132.  
  1133. function CreateEvt;
  1134. begin
  1135.   CreateEvt := CreateEvent(nil,      // address of security attributes
  1136.                            True,     // flag for manual-reset event
  1137.                            Initial,  // flag for initial state
  1138.                            nil);     // address of event-object name
  1139. end;
  1140.  
  1141. function  WaitEvtA(nCount: Integer; lpHandles: PWOHandleArray; Timeout: DWORD): DWORD;
  1142. begin
  1143.   if Timeout = High(Timeout) then Timeout := INFINITE;
  1144.   if nCount = 1 then Result := WaitForSingleObject(lpHandles^[0], Timeout) else
  1145.                      Result := WaitForMultipleObjects(nCount, lpHandles, False, Timeout);
  1146. end;
  1147.  
  1148. function WaitEvt;
  1149. begin
  1150.   Result := WaitEvtA(High(id)+1, @id, Timeout);
  1151. end;
  1152.  
  1153. function SignaledEvt(id: DWORD): Boolean;
  1154. begin
  1155.   SignaledEvt := WaitForSingleObject(id, 0) = id;
  1156. end;
  1157.  
  1158.  
  1159. ////////////////////////////////////////////////////////////////////////
  1160. //                                                                    //
  1161. //                      Win32 API Hooks                               //
  1162. //                                                                    //
  1163. ////////////////////////////////////////////////////////////////////////
  1164.  
  1165. procedure CloseHandles(const Handles: array of DWORD);
  1166. var
  1167.   i: Integer;
  1168. begin
  1169.   for i:=0 to High(Handles) do CloseHandle(Handles[i]);
  1170. end;
  1171.  
  1172. function FileExists(const FName: string): Boolean;
  1173. var
  1174.   Handle: DWORD;
  1175. begin
  1176.   Result := False;
  1177.   Handle := _CreateFile(FName, [cRead, cShareAllowWrite]);
  1178.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1179.   Result := ZeroHandle(Handle);
  1180. end;
  1181.  
  1182. function GetFileNfo;
  1183. var
  1184.   Handle: DWORD;
  1185. begin
  1186.   Result := False;
  1187.   Handle := _CreateFile(FName, [cRead, cShareAllowWrite]);
  1188.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1189.   Result := GetFileNfoByHandle(Handle, Info);
  1190.   CloseHandle(Handle);
  1191.   if NeedAttr and Result and (Info.Attr = INVALID_FILE_ATTRIBUTES) then Result := GetFileAttributes(PChar(FName)) <> INVALID_FILE_ATTRIBUTES;
  1192. end;
  1193.  
  1194. function GetFileNfoByHandle;
  1195. var
  1196.   i: TByHandleFileInformation;
  1197. begin
  1198.   Result := False;
  1199.   if Handle = INVALID_HANDLE_VALUE then Exit;
  1200.   i.dwFileAttributes := INVALID_FILE_ATTRIBUTES;
  1201.   i.nFileSizeLow := GetFileSize(Handle, nil);
  1202.   Result := (i.nFileSizeLow <> INVALID_FILE_SIZE) and GetFileTime(Handle, nil, nil, @i.ftLastWriteTime);
  1203.   if not Result then Exit;
  1204.   Info.Size := i.nFileSizeLow;
  1205.   Info.Attr := i.dwFileAttributes;
  1206.   Info.Time := uCvtGetFileTime(i.ftLastWriteTime.dwLowDateTime, i.ftLastWriteTime.dwHighDateTime);
  1207.   Result := True;
  1208. end;
  1209.  
  1210.  
  1211. function ClearHandle(var Handle: DWORD): Boolean;
  1212. begin
  1213.   if Handle = INVALID_HANDLE_VALUE then Result := False else
  1214.   begin
  1215.     Result := CloseHandle(Handle);
  1216.     Handle := INVALID_HANDLE_VALUE;
  1217.   end;
  1218. end;
  1219.  
  1220. function ZeroHandle(var Handle: DWORD): Boolean;
  1221. begin
  1222.   if (Handle = INVALID_HANDLE_VALUE) or
  1223.      (Handle = 0) then Result := False else
  1224.   begin
  1225.     Result := CloseHandle(Handle);
  1226.     Handle := 0;
  1227.   end;
  1228. end;
  1229.  
  1230. procedure _PostMessage(a, b, c, d: DWORD);
  1231. begin
  1232.   if not PostMessage(a, b, c, d) then
  1233.     GlobalFail;
  1234. end;
  1235.  
  1236. function _CreateFile;
  1237. begin
  1238.   Result := _CreateFileSecurity(FName, Mode, nil);
  1239. end;
  1240.  
  1241. function _CreateFileSecurity;
  1242. var
  1243.   Access,Share,Disp,Flags: DWORD;
  1244.  
  1245. const
  1246.   NumDispModes = 5;
  1247.   DispArr : array[1..NumDispModes] of
  1248.     record
  1249.       w: Boolean; {Write}
  1250.       n: Boolean; {EnsureNew}
  1251.       t: Boolean; {Truncate}
  1252.       d: DWORD; {Disp}
  1253.     end =
  1254.      ( (w:False; n:False; t:False; d:OPEN_EXISTING),
  1255.        (w:True;  n:False; t:False; d:OPEN_ALWAYS),
  1256.        (w:True;  n:True;  t:False; d:CREATE_NEW),
  1257.        (w:True;  n:False; t:True;  d:CREATE_ALWAYS),
  1258.        (w:True;  n:True;  t:True;  d:TRUNCATE_EXISTING) );
  1259. begin
  1260.  
  1261. // Prepare Disp & Flags
  1262.  
  1263.   Flags := FILE_ATTRIBUTE_NORMAL;
  1264.   Access := 0;
  1265.   Share := 0;
  1266.   Disp := 0;
  1267.  
  1268.   if cFlag in Mode then
  1269.   begin
  1270.     Disp := CREATE_NEW;
  1271.     Flags := Flags or FILE_FLAG_DELETE_ON_CLOSE
  1272.   end else
  1273.   begin
  1274.  
  1275.     if cTruncate in Mode then Mode := Mode + [cWrite];
  1276.  
  1277.     if cExisting in Mode then Disp := OPEN_EXISTING else
  1278.     begin
  1279.       if cWrite in Mode then Flags := FILE_ATTRIBUTE_ARCHIVE;
  1280.       repeat
  1281.         Inc(Disp); if Disp > NumDispModes then GlobalFail;
  1282.         with DispArr[Disp] do
  1283.         if (w = (cWrite in Mode)) and
  1284.            (n = (cEnsureNew in Mode)) and
  1285.            (t = (cTruncate in Mode)) then begin Disp := d; Break end;
  1286.       until False;
  1287.  
  1288.     end;
  1289.  
  1290.     if cOverlapped in Mode then Flags := Flags or FILE_FLAG_OVERLAPPED;
  1291.     if cRandomAccess in Mode then Flags := Flags or FILE_FLAG_RANDOM_ACCESS;
  1292.     if cSequentialScan in Mode then Flags := Flags or FILE_FLAG_SEQUENTIAL_SCAN;
  1293.     if cDeleteOnClose in Mode then Flags := Flags or FILE_FLAG_DELETE_ON_CLOSE;
  1294.  
  1295.  
  1296.   // Prepare 'Access' and 'Share'
  1297.  
  1298.     if cShareAllowWrite in Mode then Share := FILE_SHARE_WRITE;
  1299.     if cRead  in Mode then begin Access := Access or GENERIC_READ;  Share := Share or FILE_SHARE_READ end;
  1300.     if cWrite in Mode then begin Access := Access or GENERIC_WRITE; Share := Share or FILE_SHARE_READ end;
  1301.     if cShareDenyRead in Mode then Share := Share and not FILE_SHARE_READ;
  1302.   end;
  1303.  
  1304.   Result := CreateFile(PChar(FName), Access, Share, lpSecurityAttributes, Disp, Flags, 0);
  1305. end;
  1306.  
  1307.  
  1308. function _GetFileSize;
  1309. var
  1310.   H: DWORD;
  1311. begin
  1312.   Result := INVALID_FILE_SIZE;
  1313.   H := _CreateFile(FName, [cRead]);
  1314.   if H = INVALID_HANDLE_VALUE then Exit;
  1315.   Result := GetFileSize(H, nil);
  1316.   CloseHandle(H);
  1317. end;
  1318.  
  1319.  
  1320.  
  1321.  
  1322. function WindowsDirectory: string;
  1323. begin
  1324.   SetLength(Result, MAX_PATH);
  1325.   GetWindowsDirectory(PChar(Result), MAX_PATH);
  1326.   SetLength(Result, NulSearch(Result[1]));
  1327. end;
  1328.  
  1329.  
  1330.  
  1331. ////////////////////////////////////////////////////////////////////////
  1332. //                                                                    //
  1333. //                      Registry Routines                             //
  1334. //                                                                    //
  1335. ////////////////////////////////////////////////////////////////////////
  1336.  
  1337. function OpenRegKeyEx(const AName: string; AMode: DWORD): HKey;
  1338. begin
  1339.   if RegOpenKeyEx(
  1340.     HKEY_LOCAL_MACHINE,      // handle of an open key
  1341.     PChar(AName),           // subkey name
  1342.     0,                       // Reserved
  1343.     AMode,
  1344.     Result
  1345.   ) <> ERROR_SUCCESS then Result := INVALID_REGISTRY_KEY;
  1346. end;
  1347.  
  1348. function OpenRegKey(const AName: string): DWORD;
  1349. begin
  1350.   Result := OpenRegKeyEx(AName, KEY_QUERY_VALUE);
  1351. end;
  1352.  
  1353. function CreateRegKey(const AFName: string): HKey;
  1354. var
  1355.   Disp: DWORD;
  1356. begin
  1357.   if RegCreateKeyEx(
  1358.     HKEY_LOCAL_MACHINE,      // handle of an open key
  1359.     PChar(AFName),           // subkey name
  1360.     0,                       // reserved, must be zero
  1361.     nil,                     // address of class string
  1362.     REG_OPTION_NON_VOLATILE, // options flag
  1363.     KEY_WRITE,               // desired security access
  1364.     nil,                     // security attributes
  1365.     Result,                  // address of buffer for opened handle
  1366.     @Disp                    // address of disposition value buffer
  1367.   ) <> ERROR_SUCCESS then begin
  1368.     Result := INVALID_REGISTRY_KEY;
  1369.   end;
  1370.  
  1371. end;
  1372.  
  1373. function WriteRegString(Key: DWORD; const AStrName, AStr: string): Boolean;
  1374. begin
  1375.   Result := RegSetValueEx(Key, PChar(AStrName), 0, REG_SZ, PChar(AStr), Length(AStr)+1) = ERROR_SUCCESS;
  1376. end;
  1377.  
  1378.  
  1379. function ReadRegString(Key: DWORD; const AStrName: string): string;
  1380. var
  1381.   l, t,e: DWORD;
  1382.   z: ShortString;
  1383. begin
  1384.   z[0] := #250;
  1385.   l := 250;
  1386.   t := REG_SZ;
  1387.   e := RegQueryValueEx(
  1388.     Key,             // handle of key to query
  1389.     PChar(AStrName), // value to query
  1390.     nil,             // reserved
  1391.     @t,              // value type
  1392.     @z[1],           // data buffer
  1393.     @l               // buffer size
  1394.   );
  1395.   if e <> ERROR_SUCCESS then Result := '' else
  1396.   begin
  1397.     Result := Copy(z, 1, NulSearch(z[1]));
  1398.   end;
  1399. end;
  1400.  
  1401. function WriteRegInt(Key: DWORD; const AStrName: string; AValue: DWORD): Boolean;
  1402. begin
  1403.   Result := RegSetValueEx(Key, PChar(AStrName), 0, REG_DWORD, @AValue, SizeOf(AValue)) = ERROR_SUCCESS;
  1404. end;
  1405.  
  1406. function ReadRegInt(Key: DWORD; const AStrName: string): DWORD;
  1407. var
  1408.   t, e, s: DWORD;
  1409.   b: Integer;
  1410. begin
  1411.   t := REG_DWORD;;
  1412.   s := SizeOf(b);
  1413.   e := RegQueryValueEx(
  1414.     Key,             // handle of key to query
  1415.     PChar(AStrName), // value to query
  1416.     nil,             // reserved
  1417.     @t,              // value type
  1418.     @b,              // data buffer
  1419.     @s               // buffer size
  1420.   );
  1421.   if e <> ERROR_SUCCESS then Result := INVALID_REGISTRY_KEY else Result := b;
  1422. end;
  1423.  
  1424. function WriteRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  1425. begin
  1426.   Result := RegSetValueEx(Key, PChar(rvn), 0, REG_BINARY, Bin, Sz) = ERROR_SUCCESS;
  1427. end;
  1428.  
  1429. function ReadRegBin(Key: DWORD; const rvn: string; Bin: Pointer; Sz: DWORD): Boolean;
  1430. var
  1431.   t, e, s: DWORD;
  1432. begin
  1433.   t := REG_BINARY;;
  1434.   s := Sz;
  1435.   e := RegQueryValueEx(
  1436.     Key,             // handle of key to query
  1437.     PChar(rvn),      // value to query
  1438.     nil,             // reserved
  1439.     @t,              // value type
  1440.     Bin,             // data buffer
  1441.     @s               // buffer size
  1442.   );
  1443.   Result := e = ERROR_SUCCESS;
  1444. end;
  1445.  
  1446. ////////////////////////////////////////////////////////////////////////
  1447. //                                                                    //
  1448. //                             Objects                                //
  1449. //                                                                    //
  1450. ////////////////////////////////////////////////////////////////////////
  1451.  
  1452.  
  1453. function SysErrorMsg(ErrorCode: DWORD): string;
  1454. var
  1455.   Len: Integer;
  1456.   Buffer: array[0..255] of Char;
  1457. begin
  1458.   Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
  1459.     FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
  1460.     SizeOf(Buffer), nil);
  1461.   while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  1462.   SetString(Result, Buffer, Len);
  1463. end;
  1464.  
  1465. procedure QuickSort(SortList: PItemList; L, R: Integer;
  1466.   SCompare: TListSortCompare);
  1467. var
  1468.   I, J: Integer;
  1469.   P, T: Pointer;
  1470. begin
  1471.   repeat
  1472.     I := L;
  1473.     J := R;
  1474.     P := SortList^[(L + R) shr 1];
  1475.     repeat
  1476.       while SCompare(SortList^[I], P) < 0 do Inc(I);
  1477.       while SCompare(SortList^[J], P) > 0 do Dec(J);
  1478.       if I <= J then
  1479.       begin
  1480.         T := SortList^[I];
  1481.         SortList^[I] := SortList^[J];
  1482.         SortList^[J] := T;
  1483.         Inc(I);
  1484.         Dec(J);
  1485.       end;
  1486.     until I > J;
  1487.     if L < J then QuickSort(SortList, L, J, SCompare);
  1488.     L := I;
  1489.   until I >= R;
  1490. end;
  1491.  
  1492.  
  1493. { ---- TColl ---- }
  1494.  
  1495. procedure TColl.Sort(Compare: TListSortCompare);
  1496. begin
  1497.   if (FList <> nil) and (Count > 0) then
  1498.     QuickSort(FList, 0, Count - 1, Compare);
  1499. end;
  1500.  
  1501.  
  1502. function TColl.Copy;
  1503. begin
  1504.   Result := TColl.Create;
  1505.   CopyItemsTo(TColl(Result));
  1506. end;
  1507.  
  1508. procedure TColl.CopyItemsTo;
  1509. var
  1510.   i: Integer;
  1511. begin
  1512.   Coll.FreeAll;
  1513.   for i := 0 to Count-1 do Coll.AtInsert(Coll.Count, CopyItem(At(i)));
  1514. end;
  1515.  
  1516. function TColl.CopyItem(AItem: Pointer): Pointer;
  1517. begin
  1518.   Result := TAdvCpObject(AItem).Copy;
  1519. end;
  1520.  
  1521. procedure TColl.Concat(AColl: TColl);
  1522. var
  1523.   i: Integer;
  1524. begin
  1525.   for i := 0 to AColl.Count-1 do Insert(AColl[i]);
  1526.   AColl.DeleteAll;
  1527. end;
  1528.  
  1529.  
  1530. procedure TColl.Enter;
  1531. var
  1532.   j: Integer;
  1533. begin
  1534.   j := 1; Xchg(Shared, j); if j = 0 then InitializeCriticalSection(CS);
  1535.   EnterCriticalSection(CS);
  1536. end;
  1537.  
  1538. procedure TColl.Leave;
  1539. begin
  1540.   LeaveCriticalSection(CS);
  1541. end;
  1542.  
  1543. procedure TColl.ForEach(Proc: TForEachProc);
  1544. var
  1545.   i: Integer;
  1546. begin
  1547.   for i := 0 to Count-1 do Proc(FList^[I]);
  1548. end;
  1549.  
  1550. constructor TColl.Create;
  1551. begin
  1552.   inherited Create;
  1553.   DoInit(32,64);
  1554. end;
  1555.  
  1556. procedure TColl.DoInit(ALimit, ADelta: Integer);
  1557. begin
  1558.   FList := nil;
  1559.   FCount := 0;
  1560.   FCapacity := 0;
  1561.   FDelta := ADelta;
  1562.   SetCapacity(ALimit);
  1563. end;
  1564.  
  1565.  
  1566. destructor TColl.Destroy;
  1567. begin
  1568.   if Shared = 1 then DeleteCriticalSection(CS);
  1569.   FreeAll;
  1570.   SetCapacity(0);
  1571.   inherited Destroy;
  1572. end;
  1573.  
  1574. function TColl.At(Index: Integer): Pointer;
  1575. begin
  1576.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1577.   Result := FList^[Index];
  1578. end;
  1579.  
  1580.  
  1581. procedure TColl.AtDelete(Index: Integer);
  1582. begin
  1583.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1584.   Dec(FCount);
  1585.   if Index < FCount then
  1586.     System.Move(FList^[Index + 1], FList^[Index],
  1587.       (FCount - Index) * SizeOf(Pointer));
  1588. end;
  1589.  
  1590. procedure TColl.AtFree(Index: Integer);
  1591. var
  1592.   Item: Pointer;
  1593. begin
  1594.   Item := At(Index);
  1595.   AtDelete(Index);
  1596.   FreeItem(Item);
  1597. end;
  1598.  
  1599. procedure TColl.AtInsert(Index: Integer; Item: Pointer);
  1600. begin
  1601.   if (Index < 0) or (Index > FCount) then GlobalFail;
  1602.   if FCount = FCapacity then SetCapacity(FCapacity + FDelta);
  1603.   if Index < FCount then
  1604.     System.Move(FList^[Index], FList^[Index + 1],
  1605.       (FCount - Index) * SizeOf(Pointer));
  1606.   FList^[Index] := Item;
  1607.   Inc(FCount);
  1608. end;
  1609.  
  1610. procedure TColl.AtPut(Index: Integer; Item: Pointer);
  1611. begin
  1612.   if (Index < 0) or (Index >= FCount) then GlobalFail;
  1613.   FList^[Index] := Item;
  1614. end;
  1615.  
  1616. procedure TColl.Delete(Item: Pointer);
  1617. begin
  1618.   AtDelete(IndexOf(Item));
  1619. end;
  1620.  
  1621. procedure TColl.DeleteAll;
  1622. begin
  1623.   FCount := 0;
  1624. end;
  1625.  
  1626. procedure TColl.FFree(Item: Pointer);
  1627. begin
  1628.   Delete(Item);
  1629.   FreeItem(Item);
  1630. end;
  1631.  
  1632. procedure TColl.FreeAll;
  1633. var
  1634.   I: Integer;
  1635. begin
  1636.   for I := 0 to FCount - 1 do FreeItem(At(I));
  1637.   FCount := 0;
  1638. end;
  1639.  
  1640. procedure TColl.FreeItem(Item: Pointer);
  1641. begin
  1642.   TObject(Item).Free;
  1643. end;
  1644.  
  1645. function TColl.IndexOf(Item: Pointer): Integer;
  1646. begin
  1647.   Result := 0;
  1648.   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  1649.   if Result = FCount then Result := -1;
  1650. end;
  1651.  
  1652. procedure TColl.Insert(Item: Pointer);
  1653. begin
  1654.   AtInsert(FCount, Item);
  1655. end;
  1656.  
  1657. procedure TColl.Add(Item: Pointer);
  1658. begin
  1659.   AtInsert(FCount, Item);
  1660. end;
  1661.  
  1662. procedure TColl.Pack;
  1663. var
  1664.   I: Integer;
  1665. begin
  1666.   for I := FCount - 1 downto 0 do if Items[I] = nil then AtDelete(I);
  1667. end;
  1668.  
  1669. procedure TColl.SetCapacity;
  1670. begin
  1671.   if (NewCapacity < FCount) or (NewCapacity > MaxCollSize) then GlobalFail;
  1672.   if NewCapacity <> FCapacity then
  1673.   begin
  1674.     ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  1675.     FCapacity := NewCapacity;
  1676.   end;
  1677. end;
  1678.  
  1679. procedure TColl.MoveTo(CurIndex, NewIndex: Integer);
  1680. var
  1681.   Item: Pointer;
  1682. begin
  1683.   if CurIndex <> NewIndex then
  1684.   begin
  1685.     if (NewIndex < 0) or (NewIndex >= FCount) then GlobalFail;
  1686.     Item := FList^[CurIndex];
  1687.     AtDelete(CurIndex);
  1688.     AtInsert(NewIndex, Item);
  1689.   end;
  1690. end;
  1691.  
  1692. { TSortedColl }
  1693.  
  1694. function TSortedColl.KeyOf;
  1695. begin
  1696.   Result := Item;
  1697. end;
  1698.  
  1699. function TSortedColl.IndexOf(Item: Pointer): Integer;
  1700. var
  1701.   I: Integer;
  1702. begin
  1703.   IndexOf := -1;
  1704.   if Search(KeyOf(Item), I) then
  1705.   begin
  1706.     if Duplicates then
  1707.       while (I < Count) and (Item <> FList^[I]) do Inc(I);
  1708.     if I < Count then IndexOf := I;
  1709.   end;
  1710. end;
  1711.  
  1712. procedure TSortedColl.Insert(Item: Pointer);
  1713. var
  1714.   I: Integer;
  1715. begin
  1716.   if not Search(KeyOf(Item), I) or Duplicates then AtInsert(I, Item);
  1717. end;
  1718.  
  1719. function TSortedColl.Search(Key: Pointer; var Index: Integer): Boolean;
  1720. var
  1721.   L, H, I, C: Integer;
  1722. begin
  1723.   Search := False;
  1724.   L := 0;
  1725.   H := Count - 1;
  1726.   while L <= H do
  1727.   begin
  1728.     I := (L + H) shr 1;
  1729.     C := Compare(KeyOf(FList^[I]), Key);
  1730.     if C < 0 then L := I + 1 else
  1731.     begin
  1732.       H := I - 1;
  1733.       if C = 0 then
  1734.       begin
  1735.         Search := True;
  1736.         if not Duplicates then L := I;
  1737.       end;
  1738.     end;
  1739.   end;
  1740.   Index := L;
  1741. end;
  1742.  
  1743. { TStringColl }
  1744.  
  1745. function TStringColl.LongString: string;
  1746. var
  1747.   i: Integer;
  1748. begin
  1749.   Result := '';
  1750.   for i := 0 to Count-1 do Result := Result + Strings[i] + #13#10;
  1751. end;
  1752.  
  1753. function TStringColl.LongStringD(c: char): string;
  1754. var
  1755.   i: Integer;
  1756. begin
  1757.   Result := '';
  1758.   for i := 0 to Count-2 do Result := Result + Strings[i] + c;
  1759.   for i := MaxI(0, Count-1) to Count-1 do Result := Result + Strings[i];
  1760. end;
  1761.  
  1762. procedure TStringColl.SetTextStr(const Value: string);
  1763. var
  1764.   P, Start: PChar;
  1765.   S: string;
  1766. begin
  1767.   P := Pointer(Value);
  1768.   if P <> nil then
  1769.     while P^ <> #0 do
  1770.     begin
  1771.       Start := P;
  1772.       while not (P^ in [#0, #10, #13]) do Inc(P);
  1773.       System.SetString(S, Start, P - Start);
  1774.       Add(S);
  1775.       if P^ = #13 then Inc(P);
  1776.       if P^ = #10 then Inc(P);
  1777.     end;
  1778. end;
  1779.  
  1780.  
  1781. procedure TStringColl.FillEnum(Str: string; Delim: Char; Sorted: Boolean);
  1782. var
  1783.   Z: string;
  1784. begin
  1785.   while Str <> '' do
  1786.   begin
  1787.     GetWrd(Str, Z, Delim);
  1788.     if Sorted then Ins(Z) else Add(Z);
  1789.   end;
  1790. end;
  1791.  
  1792.  
  1793. function TStringColl.Found(const Str: string): Boolean;
  1794. var
  1795.   i: Integer;
  1796. begin
  1797.   Result := Search(@Str, I);
  1798. end;
  1799.  
  1800. function TStringColl.FoundU(const Str: string): Boolean;
  1801. var
  1802.   i: Integer;
  1803. begin
  1804.   Result := False;
  1805.   for i := 0 to Count-1 do if Str = Strings[i] then begin Result := True; Exit end;
  1806. end;
  1807.  
  1808. function TStringColl.FoundUC(const Str: string): Boolean;
  1809. var
  1810.   us: string;
  1811.   i: Integer;
  1812. begin
  1813.   us := UpperCase(Str);
  1814.   Result := False;
  1815.   for i := 0 to Count-1 do if us = UpperCase(Strings[i]) then begin Result := True; Exit end;
  1816. end;
  1817.  
  1818. function TStringColl.Copy;
  1819. begin
  1820.   Result := TStringColl.Create;
  1821.   CopyItemsTo(TColl(Result));
  1822. end;
  1823.  
  1824. function TStringColl.CopyItem(AItem: Pointer): Pointer;
  1825. begin
  1826.   Result := NewStr(PString(AItem)^);
  1827. end;
  1828.  
  1829.  
  1830. function TStringColl.KeyOf(Item: Pointer): Pointer;
  1831. begin
  1832.   KeyOf := Item;
  1833. end;
  1834.  
  1835. procedure TStringColl.Concat(AColl: TStringColl);
  1836. var
  1837.   i: Integer;
  1838. begin
  1839.   for i := 0 to AColl.Count - 1 do AtInsert(Count, AColl.At(I));
  1840.   AColl.DeleteAll;
  1841. end;
  1842.  
  1843. procedure TStringColl.AppendTo(AColl: TStringColl);
  1844. var
  1845.   i: Integer;
  1846. begin
  1847.   for i := 0 to Count - 1 do AColl.Add(Strings[i]);
  1848. end;
  1849.  
  1850. procedure TStringColl.Fill(const AStrs: array of string);
  1851. var
  1852.   i: Integer;
  1853. begin
  1854.   FreeAll;
  1855.   for i := Low(AStrs) to High(AStrs) do Add(AStrs[i]);
  1856. end;
  1857.  
  1858. procedure TStringColl.AddStrings(Strings: TStringColl; Sort: Boolean);
  1859. var
  1860.   i: Integer;
  1861. begin
  1862.   for i := 0 to Strings.Count-1 do
  1863.     if Sort then Ins(Strings[i]) else Add(Strings[i]);
  1864. end;
  1865.  
  1866. function TStringColl.IdxOf(Item: string): Integer;
  1867. begin
  1868.   Result := IndexOf(@Item);
  1869. end;
  1870.  
  1871. procedure TStringColl.SetString(Index: Integer; const Value: string);
  1872. begin
  1873.   FreeItem(At(Index));
  1874.   AtPut(Index, NewStr(Value));
  1875. end;
  1876.  
  1877. function TStringColl.GetString(Index: Integer): string;
  1878. begin
  1879.   Result := PString(At(Index))^;
  1880. end;
  1881.  
  1882. function TStringColl.Compare(Key1, Key2: Pointer): Integer;
  1883. begin
  1884.   Compare := CompareStr(PString(Key1)^, PString(Key2)^);
  1885. end;
  1886.  
  1887. procedure TStringColl.FreeItem(Item: Pointer);
  1888. begin
  1889.   DisposeStr(Item);
  1890. end;
  1891.  
  1892. procedure TStringColl.AtIns(Index: Integer; const Item: string);
  1893. begin
  1894.   AtInsert(Index, NewStr(Item));
  1895. end;
  1896.  
  1897. procedure TStringColl.Add(const S: string);
  1898. begin
  1899.   AtInsert(Count, NewStr(S));
  1900. end;
  1901.  
  1902. procedure TStringColl.Ins0(const S: string);
  1903. begin
  1904.   AtInsert(0, NewStr(S));
  1905. end;
  1906.  
  1907. procedure TStringColl.Ins(const S: string);
  1908. begin
  1909.   Insert(NewStr(S));
  1910. end;
  1911.  
  1912. procedure FreeObject(var O);
  1913. var
  1914.   OO: TObject absolute O;
  1915.   OP: Pointer absolute O;
  1916. begin
  1917.   if OP <> nil then begin OO.Free; OP := nil end;
  1918. end;
  1919.  
  1920. function DeleteEmptyDirInheritance(S: string; const StopOn: string): Integer;
  1921. begin
  1922.   Result := 0;
  1923.   while (S <> StopOn) and RemoveDirectory(PChar(S)) do
  1924.   begin
  1925.     Inc(Result);
  1926.     S := ExtractFileDir(S);
  1927.   end;
  1928. end;
  1929.  
  1930. const
  1931.   CMonths = 'JanFebMarAprMayJunJulAugSepOctNovDec';
  1932.   Months: string[Length(CMonths)] = CMonths;
  1933.  
  1934. function MonthE(m: Integer): string;
  1935. begin
  1936.   Result := Copy(Months, 1+(m-1)*3, 3);
  1937. end;
  1938.  
  1939.  
  1940. procedure GlobalFail;
  1941. begin
  1942. //  WriteLn('Global Failure!!!');
  1943.   Halt;
  1944. end;
  1945.  
  1946.  
  1947.  
  1948. function CreateTCollEL: TColl;
  1949. begin
  1950.   Result := TColl.Create;
  1951.   TColl(Result).Enter;
  1952.   TColl(Result).Leave;
  1953. end;
  1954.  
  1955. procedure XorStr(P: PByteArray; Len: Integer; const S: string);
  1956. var
  1957.   sl, i: Integer;
  1958. begin
  1959.   sl := Length(s); if sl = 0 then Exit;
  1960.   for i := 0 to Len-1 do
  1961.   begin
  1962.     P^[i] := P^[i] xor Byte(S[(i mod sl)+1]);
  1963.   end;
  1964. end;
  1965.  
  1966. function GetEnvVariable(const Name: string): string;
  1967. const
  1968.   BufSize = 128;
  1969. var
  1970.   Buf: array[0..BufSize] of Char;
  1971.   I: DWORD;
  1972. begin
  1973.   I := GetEnvironmentVariable(PChar(Name), Buf, BufSize);
  1974.   case I of
  1975.     1..BufSize:
  1976.       begin
  1977.         SetLength(Result, I);
  1978.         Move(Buf, Result[1], I);
  1979.       end;
  1980.     BufSize+1..MaxInt:
  1981.       begin
  1982.         SetLength(Result, I+1);
  1983.         GetEnvironmentVariable(PChar(Name), @Result[1], I);
  1984.         SetLength(Result, I);
  1985.       end;
  1986.     else
  1987.       begin
  1988.         Result := '';
  1989.       end;
  1990.    end;
  1991. end;
  1992.  
  1993. function LoadRS(Ident: Integer): string;
  1994. const
  1995.    strbufsize = $10000;
  1996. var
  1997.    strbuf: array[0..StrBufSize] of Char;
  1998. begin
  1999.   SetString(Result, PChar(@strbuf), LoadString(hInstance, Ident, @strbuf, strbufsize));
  2000. end;
  2001.  
  2002. function StrBegins(const s1,s2:string):Boolean;
  2003. begin
  2004.   Result := Copy(s1, 1, Length(s2)) = s2;
  2005. end;
  2006.  
  2007. function DivideDash(const S: string): string;
  2008. begin
  2009.   Result := S;
  2010.   Insert('-', Result, (Length(S) div 2)+1);
  2011. end;
  2012.  
  2013. procedure MoveColl(Src, Dst: TColl; Idx: Integer);
  2014. begin
  2015.   if Idx = -1 then Exit;
  2016.   Dst.Insert(Src[Idx]);
  2017.   Src.AtDelete(Idx);
  2018. end;
  2019.  
  2020.  
  2021. function TempFileName(const APath, APfx: string): string;
  2022. var
  2023.   s: string;
  2024. begin
  2025.   SetLength(s, 1000);
  2026.   GetTempFileName(PChar(APath), PChar(APfx), 0, @s[1]);
  2027.   Result := Copy(s, 1, NulSearch(s[1]));
  2028. end;
  2029.  
  2030. function CreateTempFile(const APath, APfx: string; var FName: string): DWORD;
  2031. begin
  2032.   FName := TempFileName(APath, APfx);
  2033.   Result := _CreateFile(FName, [cWrite, cExisting]);
  2034. end;
  2035.  
  2036. { TThread }
  2037.  
  2038. function ThreadProc(Thread: TThread): DWORD;
  2039. var
  2040.   FreeThread: Boolean;
  2041. begin
  2042.   Thread.Execute;
  2043.   FreeThread := Thread.FFreeOnTerminate;
  2044.   Result := Thread.FReturnValue;
  2045.   Thread.FFinished := True;
  2046.   if FreeThread then Thread.Free;
  2047.   EndThread(Result);
  2048. end;
  2049.  
  2050. constructor TThread.Create(CreateSuspended: Boolean);
  2051. var
  2052.   Flags: DWORD;
  2053. begin
  2054.   inherited Create;
  2055.   FSuspended := CreateSuspended;
  2056.   Flags := 0;
  2057.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  2058.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  2059. end;
  2060.  
  2061. destructor TThread.Destroy;
  2062. begin
  2063.   if FHandle <> 0 then CloseHandle(FHandle);
  2064.   inherited Destroy;
  2065. end;
  2066.  
  2067. const
  2068.   Priorities: array [TThreadPriority] of Integer =
  2069.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  2070.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  2071.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  2072.  
  2073. function TThread.GetPriority: TThreadPriority;
  2074. var
  2075.   P: Integer;
  2076.   I: TThreadPriority;
  2077. begin
  2078.   P := GetThreadPriority(FHandle);
  2079.   Result := tpNormal;
  2080.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  2081.     if Priorities[I] = P then Result := I;
  2082. end;
  2083.  
  2084. procedure TThread.SetPriority(Value: TThreadPriority);
  2085. begin
  2086.   SetThreadPriority(FHandle, Priorities[Value]);
  2087. end;
  2088.  
  2089. procedure TThread.SetSuspended(Value: Boolean);
  2090. begin
  2091.   if Value <> FSuspended then
  2092.     if Value then
  2093.       Suspend else
  2094.       Resume;
  2095. end;
  2096.  
  2097. procedure TThread.Suspend;
  2098. begin
  2099.   FSuspended := True;
  2100.   SuspendThread(FHandle);
  2101. end;
  2102.  
  2103. procedure TThread.Resume;
  2104. begin
  2105.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  2106. end;
  2107.  
  2108. procedure TThread.Terminate;
  2109. begin
  2110.   FTerminated := True;
  2111. end;
  2112.  
  2113. function NumBits(I: Integer): Integer; assembler;
  2114. asm
  2115.   bsr eax, eax
  2116.   jz @z
  2117.   inc eax
  2118. @z:
  2119. end;
  2120.  
  2121.  
  2122.  
  2123. function ExtractFilePath(const FileName: string): string;
  2124. var
  2125.   I: Integer;
  2126. begin
  2127.   I := LastDelimiter('\:', FileName);
  2128.   Result := Copy(FileName, 1, I);
  2129. end;
  2130.  
  2131. function ExtractFileDir(const FileName: string): string;
  2132. var
  2133.   I: Integer;
  2134. begin
  2135.   I := LastDelimiter('\:',Filename);
  2136.   if (I > 1) and (FileName[I] = '\') and
  2137.     (not (FileName[I - 1] in ['\', ':'])) then Dec(I);
  2138.   Result := Copy(FileName, 1, I);
  2139. end;
  2140.  
  2141. function ExtractFileDrive(const FileName: string): string;
  2142. var
  2143.   I, J: Integer;
  2144. begin
  2145.   if (Length(FileName) >= 2) and (FileName[2] = ':') then
  2146.     Result := Copy(FileName, 1, 2)
  2147.   else if (Length(FileName) >= 2) and (FileName[1] = '\') and
  2148.     (FileName[2] = '\') then
  2149.   begin
  2150.     J := 0;
  2151.     I := 3;
  2152.     While (I < Length(FileName)) and (J < 2) do
  2153.     begin
  2154.       if FileName[I] = '\' then Inc(J);
  2155.       if J < 2 then Inc(I);
  2156.     end;
  2157.     if FileName[I] = '\' then Dec(I);
  2158.     Result := Copy(FileName, 1, I);
  2159.   end else Result := '';
  2160. end;
  2161.  
  2162. function LastDelimiter(const Delimiters, S: string): Integer;
  2163. begin
  2164.   Result := Length(S);
  2165.   while Result > 0 do
  2166.   begin
  2167.     if (S[Result] <> #0) and (Pos(S[Result], Delimiters) = 0) then Dec(Result) else Break;
  2168.   end;
  2169. end;
  2170.  
  2171. function ExtractFileName(const FileName: string): string;
  2172. var
  2173.   I: Integer;
  2174. begin
  2175.   I := LastDelimiter('\:', FileName);
  2176.   Result := Copy(FileName, I + 1, MaxInt);
  2177. end;
  2178.  
  2179. function ExtractFileExt(const FileName: string): string;
  2180. var
  2181.   I: Integer;
  2182. begin
  2183.   I := LastDelimiter('.\:', FileName);
  2184.   if (I > 0) and (FileName[I] = '.') then
  2185.     Result := Copy(FileName, I, MaxInt) else
  2186.     Result := '';
  2187. end;
  2188.  
  2189. function ExpandFileName(const FileName: string): string;
  2190. var
  2191.   FName: PChar;
  2192.   Buffer: array[0..MAX_PATH - 1] of Char;
  2193. begin
  2194.   SetString(Result, Buffer, GetFullPathName(PChar(FileName), SizeOf(Buffer),
  2195.     Buffer, FName));
  2196. end;
  2197.  
  2198.  
  2199. function UpperCase(const S: string): string;
  2200. var
  2201.   Ch: Char;
  2202.   L: Integer;
  2203.   Source, Dest: PChar;
  2204. begin
  2205.   L := Length(S);
  2206.   SetLength(Result, L);
  2207.   Source := Pointer(S);
  2208.   Dest := Pointer(Result);
  2209.   while L <> 0 do
  2210.   begin
  2211.     Ch := Source^;
  2212.     if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);
  2213.     Dest^ := Ch;
  2214.     Inc(Source);
  2215.     Inc(Dest);
  2216.     Dec(L);
  2217.   end;
  2218. end;
  2219.  
  2220. function LowerCase(const S: string): string;
  2221. var
  2222.   Ch: Char;
  2223.   L: Integer;
  2224.   Source, Dest: PChar;
  2225. begin
  2226.   L := Length(S);
  2227.   SetLength(Result, L);
  2228.   Source := Pointer(S);
  2229.   Dest := Pointer(Result);
  2230.   while L <> 0 do
  2231.   begin
  2232.     Ch := Source^;
  2233.     if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);
  2234.     Dest^ := Ch;
  2235.     Inc(Source);
  2236.     Inc(Dest);
  2237.     Dec(L);
  2238.   end;
  2239. end;
  2240.  
  2241. const
  2242.   EmptyStr: string = '';
  2243.   NullStr: PString = @EmptyStr;
  2244.  
  2245. function NewStr(const S: string): PString;
  2246. begin
  2247.   if S = '' then Result := NullStr else
  2248.   begin
  2249.     New(Result);
  2250.     Result^ := S;
  2251.   end;
  2252. end;
  2253.  
  2254. procedure DisposeStr(P: PString);
  2255. begin
  2256.   if (P <> nil) and (P^ <> '') then Dispose(P);
  2257. end;
  2258.  
  2259. function CompareStr(const S1, S2: string): Integer; assembler;
  2260. asm
  2261.         PUSH    ESI
  2262.         PUSH    EDI
  2263.         MOV     ESI,EAX
  2264.         MOV     EDI,EDX
  2265.         OR      EAX,EAX
  2266.         JE      @@1
  2267.         MOV     EAX,[EAX-4]
  2268. @@1:    OR      EDX,EDX
  2269.         JE      @@2
  2270.         MOV     EDX,[EDX-4]
  2271. @@2:    MOV     ECX,EAX
  2272.         CMP     ECX,EDX
  2273.         JBE     @@3
  2274.         MOV     ECX,EDX
  2275. @@3:    CMP     ECX,ECX
  2276.         REPE    CMPSB
  2277.         JE      @@4
  2278.         MOVZX   EAX,BYTE PTR [ESI-1]
  2279.         MOVZX   EDX,BYTE PTR [EDI-1]
  2280. @@4:    SUB     EAX,EDX
  2281.         POP     EDI
  2282.         POP     ESI
  2283. end;
  2284.  
  2285. function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
  2286. asm
  2287.         PUSH    ESI
  2288.         PUSH    EDI
  2289.         MOV     ESI,P1
  2290.         MOV     EDI,P2
  2291.         MOV     EDX,ECX
  2292.         XOR     EAX,EAX
  2293.         AND     EDX,3
  2294.         SHR     ECX,1
  2295.         SHR     ECX,1
  2296.         REPE    CMPSD
  2297.         JNE     @@2
  2298.         MOV     ECX,EDX
  2299.         REPE    CMPSB
  2300.         JNE     @@2
  2301. @@1:    INC     EAX
  2302. @@2:    POP     EDI
  2303.         POP     ESI
  2304. end;
  2305.  
  2306.  
  2307. procedure TSocket.RegisterSelf;
  2308. begin
  2309.   SocketsColl.Enter;
  2310.   SocketsColl.Insert(Self);
  2311.   Registered := True;
  2312.   SocketsColl.Leave;
  2313. end;
  2314.  
  2315. procedure TSocket.DeregisterSelf;
  2316. begin
  2317.   SocketsColl.Enter;
  2318.   if Registered then SocketsColl.Delete(Self);
  2319.   Registered := False;
  2320.   SocketsColl.Leave;
  2321. end;
  2322.  
  2323.  
  2324. function TSocket.Startup: Boolean;
  2325. begin
  2326.   Result := True;
  2327. end;
  2328.  
  2329. function TSocket.Handshake: Boolean;
  2330. begin
  2331.   Result := True;
  2332. end;
  2333.  
  2334.  
  2335. destructor TSocket.Destroy;
  2336. begin
  2337.   DeregisterSelf;
  2338.   CloseSocket(Handle);
  2339.   SocketsColl.Enter;
  2340.   Dec(SocksCount);
  2341.   if SocksCount = 0 then ResetterThread.TimeToSleep := INFINITE;
  2342.   SocketsColl.Leave;
  2343.   inherited Destroy;
  2344. end;
  2345.  
  2346. function TSocket.Read(var B; Size: DWORD): DWORD;
  2347. begin
  2348.   Result := _Read(B, Size);
  2349.   Dead := 0;
  2350. end;
  2351.  
  2352. function TSocket.Write(const B; Size: DWORD): DWORD;
  2353. const
  2354.   cWrite = $4000;
  2355. var
  2356.   p: PByteArray;
  2357.   Written, Left, i, WriteNow: DWORD;
  2358. begin
  2359.   p := @B;
  2360.   i := 0;
  2361.   Left := Size;
  2362.   while Left > 0 do
  2363.   begin
  2364.     WriteNow := MinD(Left, cWrite);
  2365.     Written := _Write(p^[i], WriteNow);
  2366.     Dead := 0;
  2367.     Inc(i, Written);
  2368.     Dec(Left, Written);
  2369.     if Written <> WriteNow then Break;
  2370.   end;
  2371.   Result := i;
  2372. end;
  2373.  
  2374.  
  2375.  
  2376. function TSocket.WriteStr(const s: string): DWORD;
  2377. var
  2378.   slen: Integer;
  2379. begin
  2380.   slen := Length(s);
  2381.   if slen > 0 then Result := Write(s[1], slen) else Result := 0;
  2382. end;
  2383.  
  2384. function TSocket._Write(const B; Size: DWORD): DWORD;
  2385. var
  2386.   I: Integer;
  2387. begin
  2388.   I := send(Handle, (@B)^, Size, 0);
  2389.   if (I = SOCKET_ERROR) or (I < 0) then begin Status := WSAGetLastError; Result := 0 end else Result := I;
  2390. end;
  2391.  
  2392. function TSocket._Read(var B; Size: DWORD): DWORD;
  2393. var
  2394.   i: Integer;
  2395. begin
  2396.   i := recv(Handle, B, Size, 0);
  2397.   if (i = SOCKET_ERROR) or (I < 0) then begin Status := WSAGetLastError; Result := 0 end else Result := i;
  2398. end;
  2399.  
  2400. function Inet2addr(const s: string): DWORD;
  2401. begin
  2402.   Result := inet_addr(PChar(s));
  2403. end;
  2404.  
  2405. function __pchar(c: char): Boolean;
  2406. begin
  2407.   case c of
  2408.     ':', '@', '&', '=', '+': Result := True
  2409.     else Result := __uchar(c)
  2410.   end;
  2411. end;
  2412.  
  2413. function __uchar(c: char): Boolean;
  2414. begin
  2415.   Result := __alpha(c) or __digit(c) or __safe(c) or __extra(c) or __national(c)
  2416. end;
  2417.  
  2418. function __national(c: char): Boolean;
  2419. begin
  2420.   case c of
  2421.     '0'..'9', 'A'..'Z', 'a'..'z': Result := False;
  2422.     else Result := not (__reserved(c) or __extra(c) or __safe(c) or __unsafe(c));
  2423.   end;
  2424. end;
  2425.  
  2426. function __reserved(c: char): Boolean;
  2427. begin
  2428.   case c of
  2429.     ';', '/', '?', ':', '@', '&', '=', '+' : Result := True
  2430.     else Result := False;
  2431.   end;
  2432. end;
  2433.  
  2434. function __extra(c: char): Boolean;
  2435. begin
  2436.   case c of
  2437.     '!', '*', '''' ,'(', ')', ',' : Result := True
  2438.     else Result := False;
  2439.   end;
  2440. end;
  2441.  
  2442. function __safe(c: char): Boolean;
  2443. begin
  2444.   case c of
  2445.     '$', '-', '_', '.' : Result := True
  2446.     else Result := False;
  2447.   end;
  2448. end;
  2449.  
  2450. function __unsafe(c: char): Boolean;
  2451. begin
  2452.   case c of
  2453.       '"', '#', '%', '<', '>': Result := True;
  2454.     else Result := __ctl(c);
  2455.   end;
  2456. end;
  2457.  
  2458. function __alpha(c: char): Boolean;
  2459. begin
  2460.   case c of
  2461.     'A'..'Z', 'a'..'z': Result := True
  2462.     else Result := False;
  2463.   end;
  2464. end;
  2465.  
  2466. function __digit(c: char): Boolean;
  2467. begin
  2468.   case c of
  2469.     '0'..'9': Result := True
  2470.     else Result := False;
  2471.   end;
  2472. end;
  2473.  
  2474. function __ctl(c: char): Boolean;
  2475. begin
  2476.   case c of
  2477.     #0..#31, #127 : Result := True
  2478.     else Result := False;
  2479.   end;
  2480. end;
  2481.  
  2482.  
  2483. function UnpackXchars(var s: string; p: Boolean): Boolean;
  2484. var
  2485.   r: string;
  2486.   c: char;
  2487.   i, h, l, sl: Integer;
  2488.  
  2489. begin
  2490.   Result := False;
  2491.   sl := Length(s);
  2492.   i := 0;
  2493.   while i < sl do
  2494.   begin
  2495.     Inc(i);
  2496.     c := s[i];
  2497.     if c = '%' then
  2498.     begin
  2499.       if i > sl-2 then Exit;
  2500.       l := Pos(UpCase(s[i+2]), rrHiHexChar)-1;
  2501.       h := Pos(UpCase(s[i+1]), rrHiHexChar)-1;
  2502.       if (h = -1) or (l = -1) then Exit;
  2503.       r := r + Chr(h shl 4 or l);
  2504.       Inc(i, 2);
  2505.       Continue;
  2506.     end;
  2507.     if p then
  2508.     begin
  2509.       if not __pchar(c) and (c <> '/') then Exit;
  2510.     end else
  2511.     begin
  2512.       if not __uchar(c) then Exit
  2513.     end;
  2514.     r := r + c;
  2515.   end;
  2516.   s := r;
  2517.   Result := True;
  2518. end;
  2519.  
  2520. function UnpackUchars(var s: string): Boolean;
  2521. begin
  2522.   Result := UnpackXchars(s, False);
  2523. end;
  2524.  
  2525.  
  2526. function UnpackPchars(var s: string): Boolean;
  2527. begin
  2528.   Result := UnpackXchars(s, True);
  2529. end;
  2530.  
  2531. function ProcessQuotes(var s: string): Boolean;
  2532. var
  2533.   r: string;
  2534.   i: Integer;
  2535.   KVC: Boolean;
  2536.   c: Char;
  2537. begin
  2538.   Result := False;
  2539.   KVC := False;
  2540.   for i := 1 to Length(s) do
  2541.   begin
  2542.     c := s[i];
  2543.     case c of
  2544.       #0..#9, #11..#12, #14..#31 : Exit;
  2545.       '"' : begin KVC := not KVC; Continue end;
  2546.     end;
  2547.     if KVC then r := r + '%' + Hex2(Byte(c)) else r := r + c;
  2548.   end;
  2549.   Result := not KVC;
  2550.   if Result then s := r;
  2551. end;
  2552.  
  2553. function _Val(const S: string; var V: Integer): Boolean;
  2554. var
  2555.   I, R: Integer;
  2556.   C: Char;
  2557. begin
  2558.   Result := False;
  2559.   if S = '' then Exit;
  2560.   R := 0;
  2561.   for I := 1 to Length(S) do
  2562.   begin
  2563.     C := S[I];
  2564.     if not __digit(C) then Exit;
  2565.     R := (R * 10) + Ord(C) - Ord('0');
  2566.   end;
  2567.   Result := True;
  2568.   V := R;
  2569. end;
  2570.  
  2571.  
  2572. function StoI(const S: string): Integer;
  2573. begin
  2574.   if not _Val(S, Result) then Result := 0;
  2575. end;
  2576.  
  2577. function _LogOK(const Name: string; var Handle: DWORD): Boolean;
  2578. begin
  2579.   if Handle = 0 then
  2580.   begin
  2581.     Handle := _CreateFile(Name, [cWrite]);
  2582.     if Handle <> INVALID_HANDLE_VALUE then if SetFilePointer(Handle, 0, nil, FILE_END) = INVALID_FILE_SIZE then ClearHandle(Handle);
  2583.   end;
  2584.   Result := Handle <> INVALID_HANDLE_VALUE;
  2585. end;
  2586.  
  2587. function InetAddr(const s: string): DWORD;
  2588. begin
  2589.   Result := inet_addr(PChar(s))
  2590. end;
  2591.  
  2592. function AddrInet(i: DWORD): string;
  2593. var
  2594.   r: record a, b, c, d: Byte end absolute i;
  2595. begin
  2596.   Result := ItoS(r.a)+'.'+ItoS(r.b)+'.'+ItoS(r.c)+'.'+ItoS(r.d);
  2597. end;
  2598.  
  2599.  
  2600. const
  2601.     shell32 = 'shell32.dll';
  2602.  
  2603.  
  2604. function FindExecutable; external shell32 name 'FindExecutableA';
  2605.  
  2606.  
  2607. procedure XAdd(var Critical, Normal); assembler;
  2608. asm
  2609.   mov  ecx, [edx]
  2610.   xadd [eax], ecx  // !!! i486+
  2611.   mov  [edx], ecx
  2612. end;
  2613.  
  2614. procedure GetBias;
  2615. var
  2616.   T, L: TFileTime;
  2617.   a, b, c: DWORD;
  2618. begin
  2619.   GetSystemTimeAsFileTime(T);
  2620.   FileTimeToLocalFileTime(T, L);
  2621.   a := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  2622.   b := uCvtGetFileTime(L.dwLowDateTime, L.dwHighDateTime);
  2623.   if a > b then
  2624.   begin
  2625.     c := a - b;
  2626.     TimeZoneBias := c;
  2627.   end else
  2628.   begin
  2629.     c := b - a;
  2630.     TimeZoneBias := c;
  2631.     TimeZoneBias := - TimeZoneBias;
  2632.   end;
  2633. end;
  2634.  
  2635. type
  2636.   THostCache = class
  2637.     Addr: DWORD;
  2638.     Name: string;
  2639.   end;
  2640.  
  2641.   THostCacheColl = class(TSortedColl)
  2642.     function Compare(Key1, Key2: Pointer): Integer; override;
  2643.     function KeyOf(Item: Pointer): Pointer; override;
  2644.   end;
  2645.  
  2646. var
  2647.   HostCache: THostCacheColl;
  2648.  
  2649. function THostCacheColl.Compare(Key1, Key2: Pointer): Integer;
  2650. begin
  2651.   Result := Integer(Key1) - Integer(Key2);
  2652. end;
  2653.  
  2654. function THostCacheColl.KeyOf(Item: Pointer): Pointer;
  2655. begin
  2656.   Result := Pointer(THostCache(Item).Addr);
  2657. end;
  2658.  
  2659.  
  2660. function GetHostNameByAddr(Addr: DWORD): string;
  2661. var
  2662.   p: PHostEnt;
  2663.   i: Integer;
  2664.   f: Boolean;
  2665.   c: THostCache;
  2666.   ok: Boolean;
  2667.   he: PHostEnt;
  2668.   HostName: string;
  2669. begin
  2670.   HostCache.Enter;
  2671.   f := HostCache.Search(Pointer(Addr), i);
  2672.   if f then Result := StrAsg(THostCache(HostCache[i]).Name);
  2673.   HostCache.Leave;
  2674.   if f then Exit;
  2675.   p := gethostbyaddr(@addr, 4, PF_INET);
  2676.   ok := False;
  2677.   if p <> nil then
  2678.   begin // host name got - now get address of this name
  2679.     HostName := p^.h_name;
  2680.     he := gethostbyname(PChar(HostName));
  2681.     if (he <> nil) and (he^.h_addr_list <> nil) then
  2682.     begin // address got - now compare it with the real one
  2683.       ok := PDwordArray(he^.h_addr_list^)^[0] = Addr;
  2684.     end;
  2685.   end;
  2686.   if ok then Result := HostName else Result := AddrInet(Addr);
  2687.   HostCache.Enter;
  2688.   f := HostCache.Search(Pointer(Addr), i);
  2689.   if not f then
  2690.   begin
  2691.     c := THostCache.Create;
  2692.     c.Addr := Addr;
  2693.     c.Name := StrAsg(Result);
  2694.     HostCache.AtInsert(i, c);
  2695.   end;
  2696.   HostCache.Leave;
  2697. end;
  2698.  
  2699. function Vl(const s: string): DWORD;
  2700. var
  2701.   a, i, l: Integer;
  2702.   c: Char;
  2703. begin
  2704.   Result := INVALID_VALUE;
  2705.   l := Length(s);
  2706.   if L > 9 then Exit;
  2707.   a := 0;
  2708.   for i := 1 to l do
  2709.   begin
  2710.     C := s[i];
  2711.     if (C < '0') or (C > '9') then Exit;
  2712.     a := a * 10 + Ord(C) - Ord('0');
  2713.   end;
  2714.   Result := a;
  2715. end;
  2716.  
  2717.  
  2718. procedure xBaseInit;
  2719. begin
  2720.   GetBias;
  2721.   HostCache := THostCacheColl.Create;
  2722.   HostCache.Enter;
  2723.   HostCache.Leave;
  2724. end;
  2725.  
  2726. procedure xBaseDone;
  2727. begin
  2728.   FreeObject(HostCache);
  2729. end;
  2730.  
  2731. constructor TResetterThread.Create;
  2732. begin
  2733.   inherited Create(False);
  2734.   oSleep := CreateEvent(nil, False, False, nil);
  2735.   TimeToSleep := INFINITE;
  2736. end;
  2737.  
  2738. destructor TResetterThread.Destroy;
  2739. begin
  2740.   CloseHandle(oSleep);
  2741.   inherited Destroy;
  2742. end;
  2743.  
  2744.  
  2745. procedure TResetterThread.Execute;
  2746. const
  2747.   KillQuants = 5; // Quants to shut down socket for inactivity
  2748. var
  2749.   i: Integer;
  2750.   s: TSocket;
  2751. begin
  2752.   repeat
  2753.     WaitForSingleObject(oSleep, TimeToSleep);
  2754.     if Terminated then Break;
  2755.     SocketsColl.Enter;
  2756.     for i := 0 to SocketsColl.Count - 1 do
  2757.     begin
  2758.       s := SocketsColl[i];
  2759.       if s.Dead < 0 then Continue; // Already shut down
  2760.       Inc(s.Dead);
  2761.       if s.Dead <= KillQuants then Continue; // This one shows activity - let him live
  2762.       s.Dead := -1; // Mark
  2763.        // disable both sends and receives
  2764.       shutdown(s.Handle, 2);
  2765.     end;
  2766.     SocketsColl.Leave;
  2767.   until Terminated;
  2768. end;
  2769.  
  2770.  
  2771. function CompareMask(const n, m: string; SupportPercent: Boolean): Boolean;
  2772. var
  2773.   i: Integer;
  2774. begin
  2775.   Result := False;
  2776.   for i := 1 to Length(m) do
  2777.   begin
  2778.     if (m[i] = '?') then Continue;
  2779.     if (i > Length(n)) or (n[i] <> m[i]) then
  2780.     begin
  2781.       if SupportPercent and (m[i] = '%') and (n[i] in ['0'..'9']) then else Exit;
  2782.     end;
  2783.   end;
  2784.   Result := True;
  2785. end;
  2786.  
  2787. function PosMask(const m, s: string; SupportPercent: Boolean): Integer;
  2788. var
  2789.   i: Integer;
  2790. begin
  2791.   Result := 0;
  2792.   for i := 1 to Length(s)-Length(m)+1 do
  2793.   begin
  2794.     if CompareMask(Copy(s, i, Length(m)), m, SupportPercent) then
  2795.     begin
  2796.       Result := i;
  2797.       Exit;
  2798.     end;
  2799.   end;
  2800. end;
  2801.  
  2802. function MatchMask(const AName, AMask: string): Boolean;
  2803. begin
  2804.   Result := _MatchMask(AName, AMask, False);
  2805. end;
  2806.  
  2807. function _MatchMaskBody(AName, AMask: string; SupportPercent: Boolean): Boolean;
  2808. var
  2809.   i, j: Integer;
  2810.   Scan: Boolean;
  2811. begin
  2812.   Result := False;
  2813.   Scan := False;
  2814.   while True do
  2815.   begin
  2816.     i := Pos('*', AMask);
  2817.     if i = 0 then
  2818.     begin
  2819.       if AMask = '' then begin Result := True; Exit end;
  2820.       j := PosMask(AMask, AName, SupportPercent); if j=0 then Exit;
  2821.       if (j+Length(AMask)) <= Length(AName) then Exit;
  2822.       Result := True;
  2823.       Exit;
  2824.     end else
  2825.     begin
  2826.       if i > 1 then
  2827.       begin
  2828.         if Scan then j := PosMask(Copy(AMask, 1, i-1), AName, SupportPercent) else if CompareMask(AName, Copy(AMask, 1, i-1), SupportPercent) then j := i-1 else j := 0;
  2829.         if j = 0 then Exit else Delete(AName, 1, j);
  2830.       end;
  2831.       Delete(AMask, 1, i);
  2832.     end;
  2833.     Scan := True;
  2834.   end;
  2835. end;
  2836.  
  2837. function _MatchMask(const AName: string; AMask: string; SupportPercent: Boolean): Boolean;
  2838. begin
  2839.   Replace('?*', '*', AMask);
  2840.   Replace('*?', '*', AMask);
  2841.   Replace('**', '*', AMask);
  2842.   Result := _MatchMaskBody(UpperCase(AName), UpperCase(AMask), SupportPercent);
  2843. end;
  2844.  
  2845. function FromHex(C1, C2: Char): Char;
  2846.   var I1, I2: Byte;
  2847. begin
  2848.   case C1 of
  2849.     '0'..'9': I1 := Byte(C1)-48;
  2850.     'A'..'F': I1 := Byte(C1)-55;
  2851.     'a'..'f': I1 := Byte(C1)-87;
  2852.       else I1 := 0;
  2853.   end;
  2854.   case C2 of
  2855.     '0'..'9': I2 := Byte(C2)-48;
  2856.     'A'..'F': I2 := Byte(C2)-55;
  2857.     'a'..'f': I2 := Byte(C2)-87;
  2858.       else I2 := 0;
  2859.   end;
  2860.   Result := Char(I1 shl 4 + I2);
  2861. end;
  2862.  
  2863. constructor TMimeCoder.Create;
  2864. begin
  2865.   case AType of
  2866.     bsBase64: begin
  2867.                 Table:='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  2868.                 MaxChars := 57;
  2869.                 Pad := '=';
  2870.               end;
  2871.     bsUUE: begin
  2872.              Table := '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
  2873.              Pad := '`';
  2874.              MaxChars := 45;
  2875.            end;
  2876.     bsXXE: begin
  2877.              Table := '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  2878.              Pad := '+';
  2879.              MaxChars := 45;
  2880.            end;
  2881.   end;
  2882.   InitTable;
  2883. end;
  2884.  
  2885. procedure TMimeCoder.InitTable;
  2886.   var I: Integer;
  2887. begin
  2888.   FillChar(XChars, SizeOf(XChars), 65);
  2889.   for I := 1 to Length(Table) do XChars[Table[I]] := I-1;
  2890.   XChars[Pad] := 0;
  2891.   if Pad = '`' then XChars[' '] := 0;
  2892. end;
  2893.  
  2894. function TMimeCoder.EncodeStr;
  2895. begin
  2896.   if S = '' then Result := ''
  2897.     else Result := Encode(S[1], Length(S));
  2898. end;
  2899.  
  2900. function IsUUEStr(const S: String): Boolean;
  2901.   var I: Integer;
  2902. begin
  2903.   Result := False;
  2904.   for I := 1 to Length(S) do
  2905.     if (S[I] < '!') or (S[I] > '`') then Exit;
  2906.   Result := True;
  2907. end;
  2908.  
  2909. function TMimeCoder.Encode;
  2910. var
  2911.   B: Array[0..MMaxChars] of Byte;
  2912.   I,K,L: Word;
  2913.   S: Str255;
  2914. begin
  2915.   FillChar(B, SizeOf(B), 0);
  2916.   Move(Buf, B, N);
  2917.   L := N;
  2918.   if L mod 3 <> 0 then Inc(L, 3);
  2919.   S[0] := Char((L div 3) * 4);
  2920.   FillChar(S[1], Length(S), Pad);
  2921.   I := 0; K := 1;
  2922.   while I < N do
  2923.     begin
  2924.       S[K]   := Table[1+(B[I] shr 2)];
  2925.       S[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
  2926.       if I+1 >= N then Break;
  2927.       S[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
  2928.       if I+2 >= N then Break;
  2929.       S[K+3] := Table[1+(B[I+2] and $3F)];
  2930.       Inc(I, 3); Inc(K, 4);
  2931.     end;
  2932.   Result := S;
  2933. end;
  2934.  
  2935. function TMimeCoder.EncodeBuf(const Buf; N: byte; var OutBuf) : Integer;
  2936. var
  2937.   B: Array[0..MMaxChars] of Byte;
  2938.   I,K,L: Word;
  2939.   p: PCharArray;
  2940. begin
  2941.   p := @OutBuf;
  2942.   FillChar(B, SizeOf(B), 0);
  2943.   Move(Buf, B, N);
  2944.   L := N;
  2945.   if L mod 3 <> 0 then Inc(L, 3);
  2946.   Result := (L div 3) * 4;
  2947.   FillChar(p^, Result, Pad);
  2948.   I := 0; K := 0;
  2949.   while I < N do
  2950.     begin
  2951.       p^[K]   := Table[1+(B[I] shr 2)];
  2952.       p^[K+1] := Table[1+(((B[I] and $03) shl 4) or (B[I+1] shr 4))];
  2953.       if I+1 >= N then Break;
  2954.       p^[K+2] := Table[1+(((B[I+1] and $0F) shl 2) or (B[I+2] shr 6))];
  2955.       if I+2 >= N then Break;
  2956.       p^[K+3] := Table[1+(B[I+2] and $3F)];
  2957.       Inc(I, 3); Inc(K, 4);
  2958.     end;
  2959. end;
  2960.  
  2961.  
  2962.  
  2963.  
  2964. function TMimeCoder.Decode;
  2965.   var B: array [0..MMaxChars] of Byte absolute Buf;
  2966.       A: array [0..MMaxChars] of Byte;
  2967.       I,J,K, Pdd: Integer;
  2968. begin
  2969.   if S = '' then begin Result := 0; Exit end;
  2970.   Result := -1;
  2971.   FillChar(A, SizeOf(A), 0);
  2972.   for I := 0 to Length(S)-1 do
  2973.     begin
  2974.       A[I] := XChars[S[I+1]];
  2975.       if A[I] > 64 then Exit;
  2976.     end;
  2977.   J := Length(S);
  2978.   Pdd := 3;
  2979.   if (Pad = '=') then
  2980.     while S[J] = Pad do begin Dec(Pdd); Dec(J) end;
  2981.   Pdd := Pdd mod 3;
  2982.   Result := (J div 4) * 3 + Pdd;
  2983.   I := 0; K := 0;
  2984.   while I < J do
  2985.     begin
  2986.       B[K] := ((A[I] shl 2) or (A[I+1] shr 4)) and $FF;
  2987.       B[K+1] := ((A[I+1] shl 4) or (A[I+2] shr 2)) and $FF;
  2988.       B[K+2] := ((A[I+2] shl 6) or (A[I+3])) and $FF;
  2989.       Inc(I, 4); Inc(K, 3);
  2990.     end;
  2991. end;
  2992.  
  2993. function TMimeCoder.DecodeBuf(const SrcBuf; SrcLen: Integer; var Buf): Integer;
  2994. var
  2995.   B: array [0..MMaxChars] of Byte absolute Buf;
  2996.   A: array [0..MMaxChars] of Byte;
  2997.   I,J,K, Pdd: Integer;
  2998.   p: PByteArray;
  2999. begin
  3000.   p := @SrcBuf;
  3001.   if SrcLen = 0 then begin Result := 0; Exit end;
  3002.   Result := -1;
  3003.   FillChar(A, SizeOf(A), 0);
  3004.   for I := 0 to SrcLen-1 do
  3005.     begin
  3006.       A[I] := XChars[Char(P^[I])];
  3007.       if A[I] > 64 then Exit;
  3008.     end;
  3009.   J := SrcLen;
  3010.   Pdd := 3;
  3011.   if (Pad = '=') then
  3012.     while (J>0) and (Char(p^[J-1]) = Pad) do begin Dec(Pdd); Dec(J) end;
  3013.   Pdd := Pdd mod 3;
  3014.   Result := (J div 4) * 3 + Pdd;
  3015.   I := 0; K := 0;
  3016.   while I < J do
  3017.     begin
  3018.       B[K] := ((A[I] shl 2) or (A[I+1] shr 4)) and $FF;
  3019.       B[K+1] := ((A[I+1] shl 4) or (A[I+2] shr 2)) and $FF;
  3020.       B[K+2] := ((A[I+2] shl 6) or (A[I+3])) and $FF;
  3021.       Inc(I, 4); Inc(K, 3);
  3022.     end;
  3023. end;
  3024.  
  3025. function StrAsg(const Src: string): string;
  3026. begin
  3027.   if Src = '' then Result := '' else
  3028.   begin
  3029.     SetLength(Result, Length(Src));
  3030.     Move(Src[1], Result[1], Length(Src));
  3031.   end;
  3032. end;
  3033.  
  3034.  
  3035. end.
  3036.  
  3037.  
  3038.